Developer CD Series 1993…ch: Other People's Memory/ADC Developer CD (1993-03) (''Other People's Memory'')_iso/Dev.CD Mar 93.iso/Development Platforms/LISP Related/LISP Goodies/Wood/btrees.lisp

Text File | 1992-09-02 | 122.4 KB | 2,288 lines | [TEXT/CCL2]

;;;-*- Mode: Lisp; Package: WOOD -*-

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; btrees.lisp
;;; B* trees with variable length keys for pheaps.
;;;
;;; Copyright © 1992 Apple Computer, Inc. All rights reserved.
;;; Permission is given to use, copy, and modify this software provided
;;; that this copyright notice is attached to all derivative works.
;;; This software is provided "as is". Apple makes no warranty or
;;; representation, either express or implied, with respect to this software,
;;; its quality, accuracy, merchantability, or fitness for a particular
;;; purpose.
;;;

;;; Key size is limited to 127 bytes with longer keys
;;; being stored as strings (and requiring an extra disk access).
;;; (longer strings are not yet implemented).

;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Modification History
;;;
;;; -------------- 0.5
;;; 07/28/92 bill  make p-map-btree deal correctly with insertion or
;;;                deletion while mapping.
;;; 07/27/92 bill  p-clear-btree, p-map-btree
;;; 06/30/92 bill  little bug in %split-btree-root
;;; 06/26/92 bill  btree vector indices defs -> woodequ
;;; 06/23/92 bill  Don't ignore type in p-make-btree
;;; -------------- 0.1
;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; To do:
;;;
;;; 1) Maybe.
;;;    Replace the $btree_parent slot with $btree_mod-count for locking use.
;;;    Updating parents at shift or split time is too expensive.
;;;    Instead, pass around an ancestors list (stack-consed).
;;;
;;; 2) Implement keys longer than 127 bytes.

(in-package :wood)

(export '(p-make-btree p-btree-lookup p-btree-store p-btree-delete
          dc-make-btree dc-btree-lookup dc-btree-store dc-btree-delete))

;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Node layout - subtype $v_btree-node
;;;
;;;  -------------------
;;; | $vector-header    |
;;; | subtype length    |
;;; |-------------------|
;;; | link              |
;;; | parent            |
;;; | used free         |
;;; | count flags       |
;;; | pointer[0]        |
;;; | len[1] key[1] ... |
;;; | pointer[1]        |
;;; | len[2] key[2] ... |
;;; |        ...        |
;;; | len[m] key[m] ... |
;;; | pointer[m]        |
;;;  -------------------

;;; $vector-header is the standard vector header marker
;;; subtype is one byte, it's value is $v_btree-node
;;; length is the total length of the data portion of the block in bytes
;;; link is used by the GC so that it can walk btree nodes last.
;;; parent points at the parent node of this one, or at the btree
;;;   uvector for the root.
;;; used is 16 bits: the number of bytes that are in use at $btree_data
;;; free is 16 bits: the number of free bytes at the end of the block.
;;; count is 16 bits: the number of entries in this node
;;; flags is 16 bits of flags.
;;;   Bit 0 is set for a leaf page.
;;;   Bit 1 is set for the root page.
;;; pointer[i] is 4 bytes aligned on a 4-byte boundary.
;;;   For a non-leaf node, it points at another node in the tree
;;;   For a leaf node, it points at the indexed data.
;;;   pointer[m] for a leaf node points to the next leaf node.
;;; len[i] is a bytes giving the length of key[i]
;;;   if len[i] is 255, then there are three unused bytes followed
;;;   by a four byte pointer to a string containing the key.
;;;   otherwise, len[i] will always be < 128
;;;   (keys longer than 127 bytes are not yet implemented)
;;; key[i] is len[i] bytes of characters for the key followed
;;;   by enough padding bytes to get to the next 4-byte boundary.

(defconstant $btree_link $v_data)
(defconstant $btree_parent (+ $btree_link 4))
(defconstant $btree_used (+ $btree_parent 4))
(defconstant $btree_free (+ $btree_used 2))
(defconstant $btree_count (+ $btree_free 2))
(defconstant $btree_flags (+ $btree_count 2))
(defconstant $btree_data (+ $btree_flags 2))

(defconstant $btree_flags.leaf-bit 0)
(defconstant $btree_flags.root-bit 1)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; The documented interface
;;;

(defun p-make-btree (pheap &key area type)
  (pptr pheap
        (dc-make-btree (pheap-disk-cache pheap)
                       (and area (pheap-pptr-pointer area pheap))
                       (and type (require-type type 'fixnum)))))

(defun p-btree-lookup (btree key-string &optional default)
  (let ((pheap (pptr-pheap btree)))
    (multiple-value-bind (pointer immediate? found?)
                         (dc-btree-lookup
                          (pheap-disk-cache pheap)
                          (pptr-pointer btree)
                          (if (stringp key-string)
                            key-string
                            (p-load key-string)))
      (if found?
        (values
         (if immediate?
           pointer
           (pptr pheap pointer))
         t)
        default))))

(defun p-btree-store (btree key-string default &optional (value default))
  (let ((pheap (pptr-pheap btree)))
    (multiple-value-bind (pointer immediate?)
                         (%p-store pheap value)
    (dc-btree-store
     (pheap-disk-cache pheap)
     (pptr-pointer btree)
     (if (stringp key-string)
       key-string
       (p-load key-string))
     pointer
     immediate?)
    (if immediate?
      pointer
      (pptr pheap pointer)))))

(defsetf p-btree-lookup p-btree-store)

(defun p-btree-delete (btree key-string)
  (dc-btree-delete
   (pptr-disk-cache btree)
   (pptr-pointer btree)
   (if (stringp key-string)
     key-string
     (p-load key-string))))

(defun p-clear-btree (btree)
  (dc-clear-btree (pptr-disk-cache btree)
                  (pptr-pointer btree))
  btree)

(defun p-map-btree (btree function &optional from to)
  (let* ((pheap (pptr-pheap btree))
         (f #'(lambda (disk-cache key value imm?)
                (declare (ignore disk-cache))
                (funcall function key (if imm? value (pptr pheap value))))))
    (declare (dynamic-extent f))
    (dc-map-btree (pheap-disk-cache pheap)
                  (pptr-pointer btree)
                  f
                  (if (or (null from) (stringp from))
                    from
                    (p-load from))
                  (if (or (null to) (stringp to))
                    to
                    (p-load to)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; disk-cache versions of the documented interface
;;;

(defun dc-make-btree (disk-cache &optional area type)
  (let* ((btree (dc-make-uvector disk-cache $btree-size $v_btree area 0 t))
         (root (dc-cons-btree-node
                 disk-cache btree btree
                 (logior (ash 1 $btree_flags.leaf-bit) (ash 1 $btree_flags.root-bit)))))
    (accessing-disk-cache (disk-cache)
      (svset.p btree $btree.root root)
      (svset.p btree $btree.first-leaf root)
      (when type
        (svset.p btree $btree.type (require-type type 'fixnum) t)))
    btree))

(defun dc-btree-lookup (disk-cache btree key-string)
  (multiple-value-bind (node offset eq)
                       (btree-find-leaf-node disk-cache btree key-string)
    (when eq
      (multiple-value-bind (pointer immediate?)
                           (read-pointer disk-cache (+ node offset))
        (values pointer immediate? t)))))

(defun dc-btree-store (disk-cache btree key-string value &optional
                                       value-imm?)
  (if (> (length key-string) 127)
    (error "Keys longer than 127 bytes not supported yet."))
  (multiple-value-bind (node offset eq)
                       (btree-find-leaf-node disk-cache btree key-string)
    (if eq
      (setf (read-pointer disk-cache (+ node offset) value-imm?)
            value)
      (progn
        (%btree-insert-in-leaf-node
         disk-cache btree node offset key-string value value-imm?)
        (accessing-disk-cache (disk-cache)
          (svset.p btree $btree.count (1+ (svref.p btree $btree.count)) t))
        (values value value-imm?)))))

(defun dc-btree-delete (disk-cache btree key-string)
  (if (> (length key-string) 127)
    (error "Keys longer than 127 bytes not supported yet."))
  (multiple-value-bind (node offset eq)
                       (btree-find-leaf-node disk-cache btree key-string)
    (when eq
      (%btree-delete-from-node disk-cache btree node offset t)
      (accessing-disk-cache (disk-cache)
        (svset.p btree $btree.count (1- (svref.p btree $btree.count)) t))
      t)))

(defun dc-clear-btree (disk-cache btree)
  (require-satisfies dc-vector-subtype-p disk-cache btree $v_btree)
  (let* ((root-node (dc-%svref disk-cache btree $btree.root))
         (first-leaf (dc-%svref disk-cache btree $btree.first-leaf)))
    (accessing-disk-cache (disk-cache first-leaf)
      (multiple-value-bind (node used free) (init-btree-node disk-cache first-leaf)
        (declare (ignore node))
        (fill.b (+ $btree_data used) 0 free))
      (store.l btree $btree_parent)
      (store.w (logior (ash 1 $btree_flags.root-bit)
                       (ash 1 $btree_flags.leaf-bit)
                       (load.w $btree_flags))
               $btree_flags))
    (dc-%svfill disk-cache btree
      $btree.root first-leaf
      ($btree.count t) 0
      ($btree.count t) 0
      ($btree.nodes t) 1)
    (dc-%clear-node disk-cache root-node first-leaf))
  btree)

(defun dc-%clear-node (disk-cache node first-leaf)
  (require-satisfies dc-vector-subtype-p disk-cache node $v_btree-node)
  (unless (eql node first-leaf)
    (with-locked-page (disk-cache node nil buf offset)
      (accessing-byte-array (buf offset)
        (unless (logbitp $btree_flags.leaf-bit (load.w $btree_flags))
          (let ((p $btree_data))
            (declare (fixnum p))
            (dotimes (i (load.w $btree_count))
              (dc-%clear-node disk-cache (load.l p) first-leaf)
              (incf p 4)
              (incf p (normalize-size (1+ (load.b p)) 4)))
            (dc-%clear-node disk-cache (load.l p) first-leaf)))
        (dc-free-btree-node disk-cache nil node)))))

(defun dc-map-btree (disk-cache btree function &optional from to)
  (unless (or (null from) (stringp from))
    (setq from (require-type from '(or null string))))
  (unless (or (null to) (stringp to))
    (setq to (require-type to '(or null string))))
  (multiple-value-bind (node p)
                       (if from
                         (btree-find-leaf-node disk-cache btree from)
                         (values (dc-%svref disk-cache btree $btree.first-leaf)
                                 $btree_data))
    (declare (fixnum p))
    (loop
      (block once-per-node
        (with-locked-page (disk-cache node nil buf buf-offset)
          (accessing-byte-array (buf buf-offset)
            (let ((max-p (+ $btree_data (load.w $btree_used) -4)))
              (declare (fixnum max-p))
              (loop
                (when (>= p max-p)
                  (when (> p max-p)
                    (error "Inconsistency: pointer off end of btree node"))
                  (return))
                (multiple-value-bind (value imm?) (load.p p)
                  (let* ((len (load.b (incf p 4)))
                         (key (make-string len)))
                    (declare (fixnum len)
                             (dynamic-extent key))
                    (load.string (the fixnum (1+ p)) len key)
                    (when (and to (string< to key))
                      (return-from dc-map-btree nil))
                    (funcall function disk-cache key value imm?)
                    (let ((newlen (load.b p)))
                      (declare (fixnum newlen))
                      (unless (and (eql newlen len)
                                   (let ((new-key (make-string newlen)))
                                     (declare (dynamic-extent new-key))
                                     (load.string (the fixnum (1+ p)) newlen new-key)
                                     (string= key new-key)))
                        ; The user inserted or deleted something that caused
                        ; the key to move. Need to find it again.
                        (let (eq)
                          (multiple-value-setq (node p eq)
                            (btree-find-leaf-node disk-cache btree key))
                          (when eq
                            (incf p (normalize-size (1+ len) 4)))
                          (return-from once-per-node))))
                    (incf p (normalize-size (1+ len) 4))))))
            (setq node (load.l p)
                  p $btree_data)
            (when (eql node $pheap-nil)
              (return nil))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Grungy internal details
;;; First, some generally useful utility functions
;;;

(defun dc-cons-btree-node (disk-cache btree parent flags)
  (let ((node (or (with-locked-page (disk-cache (+ $root-vector $v_data
                                                   (* 4 $pheap.btree-free-list)))
                    (accessing-disk-cache (disk-cache)
                      (let ((free-list (svref.p $root-vector $pheap.btree-free-list)))
                        (unless (eql $pheap-nil free-list)
                          (svset.p $root-vector $pheap.btree-free-list
                                   (accessing-disk-cache (disk-cache free-list)
                                     (load.l $btree_parent)))
                          free-list))))
                  (init-btree-node
                   disk-cache
                   (%dc-allocate-new-memory disk-cache 1 $v_btree-node 0 t)))))
    (accessing-disk-cache (disk-cache node)
      (store.l parent $btree_parent)
      (store.w flags $btree_flags))
    (with-locked-page (disk-cache (+ btree $v_data (* 4 $btree.nodes)) t)
      (accessing-disk-cache (disk-cache)
        (svset.p btree $btree.nodes (1+ (svref.p btree $btree.nodes)) t)))
    node))

(defun dc-free-btree-node (disk-cache btree node)
  (multiple-value-bind (node used free) (init-btree-node disk-cache node)
    (accessing-disk-cache (disk-cache node)
      (fill.b (+ $btree_data used) 0 free)))
  (with-locked-page (disk-cache $root-vector t)
    (accessing-disk-cache (disk-cache)
      (let ((free-list (svref.p $root-vector $pheap.btree-free-list)))
        (accessing-disk-cache (disk-cache node)
          (store.l free-list $btree_parent)))
      (svset.p $root-vector $pheap.btree-free-list node)))
  (when btree
    (with-locked-page (disk-cache (+ btree $v_data (* 4 $btree.nodes)) t)
      (accessing-disk-cache (disk-cache)
        (svset.p btree $btree.nodes (1- (svref.p btree $btree.nodes)) t)))))

(defun init-btree-node (disk-cache node)
  (accessing-disk-cache (disk-cache node)
    (let* ((vector-size (%vector-size.p node))
           (data-size (- vector-size (- $btree_data $v_data)))
           (used 4)
           (free (- data-size used)))
      (store.l $pheap-nil $btree_link)
      (store.w used $btree_used)
      (store.w free $btree_free)
      (store.w 0 $btree_count)
      (store.l $pheap-nil $btree_data)
      (values node used free))))

(defun %btree-leaf-node-p (disk-cache node)
  (accessing-disk-cache (disk-cache node)
    (logbitp $btree_flags.leaf-bit (load.w $btree_flags))))

(defun %btree-root-node-p (disk-cache node)
  (accessing-disk-cache (disk-cache node)
    (logbitp $btree_flags.root-bit (load.w $btree_flags))))

; Returns two values:
; 1) offset - from node for the place where key-string goes
; 2) eq     - True if the key at this offset is key-string
(defun btree-find-leaf-node (disk-cache btree key-string)
  (require-satisfies dc-vector-subtype-p disk-cache btree $v_btree)
  (let ((node (dc-%svref disk-cache btree $btree.root)))
    (loop
      (multiple-value-bind (offset eq)
                           (%btree-search-node disk-cache node key-string)
        (when (%btree-leaf-node-p disk-cache node)
          (return (values node offset eq)))
        (setq node (read-long disk-cache (+ node offset)))
        (require-satisfies dc-vector-subtype-p
                           disk-cache node $v_btree-node)))))

; This one calls the disk-cache code directly and accesses the
; page vector itself so that it can be reasonably fast.
; Returns same two values as btree-find-leaf-node
; plus a third value which is the offset to the node just to the left of the found one.
(defun %btree-search-node (disk-cache node key-string)
  (with-locked-page (disk-cache node nil vec offset bytes)
    (declare (fixnum offset bytes))
    (accessing-byte-array (vec offset)
      (let* ((end (+ offset $btree_data (load.uw $btree_used)))
             (ptr (+ offset $btree_data 4))
             (last-ptr nil))
        (declare (fixnum end ptr))
        (declare (fixnum offset bytes))
        (unless (>= (the fixnum (+ offset bytes)) end)
          (error "End of btree node is past end of disk page"))
        (loop
          (if (>= ptr end)
            (return (values (- ptr offset 4)
                            nil
                            (if last-ptr (- last-ptr offset 4)))))
          (let* ((len (aref vec ptr))
                 (str (make-string len)))
            (declare (dynamic-extent str))
            (%copy-byte-array-portion vec (the fixnum (1+ ptr)) len str 0)
            ; Here's where we'll eventually use part of the
            ; $btree_flags to select a sorting predicate.
            (let ((compare (compare-strings key-string str)))
              (declare (fixnum compare))
              (when (<= compare 0)
                     (return (values (- ptr offset 4)
                                     (eql compare 0)
                                     (if last-ptr (- last-ptr offset 4))))))
            (setq last-ptr ptr)
            (incf ptr (normalize-size (+ 5 len) 4))))))))

(defun compare-strings (str1 str2)
  (cond ((string< str1 str2) -1)
        ((string= str1 str2) 0)
        (t 1)))

; Search a node for a pointer to a subnode.
; Return two values, the offset for the subnode, and the offset
; for the subnode just before it.
(defun %btree-search-for-subnode (disk-cache node subnode)
  (with-locked-page (disk-cache node nil vec offset bytes)
    (declare (fixnum offset bytes))
    (accessing-byte-array (vec offset)
      (let* ((end (+ offset $btree_data (load.uw $btree_used)))
             (ptr (+ offset $btree_data))
             (last-ptr nil))
        (declare (fixnum end ptr))
        (declare (fixnum offset bytes))
        (unless (>= (the fixnum (+ offset bytes)) end)
          (error "End of btree node is past end of disk page"))
        (accessing-byte-array (vec)
          (loop
            (when (eql subnode (load.p ptr))
              (return (values (- ptr offset)
                              (if last-ptr (- last-ptr offset)))))
            (setq last-ptr ptr)
            (incf ptr 4)
            (if (>= ptr end)
              (return nil))
            (incf ptr (normalize-size (1+ (load.b ptr)) 4))))))))

; Fill the SIZES array with the sizes of the entries in NODE.
; If one of the entries is at INSERT-OFFSET, put INSERT-SIZE
; into SIZES at that index, and return the index.
; Otherwise, return NIL.
(defun %lookup-node-sizes (disk-cache node sizes count &optional insert-offset insert-size
                                      (start 0))
  (accessing-disk-cache (disk-cache node)
    (unless count
      (setq count (load.uw $btree_count)))
    (when insert-offset (incf count))
    (let ((p (+ $btree_data 4))
          (p-at-offset (and insert-offset (+ insert-offset 4)))
          insert-index
          (index (require-type start 'fixnum)))
      (declare (fixnum p))
      (dotimes (i count)
        (if (eql p p-at-offset)
          (setf (aref sizes index) insert-size
                insert-index index
                p-at-offset nil)
          (incf p (setf (aref sizes index) (normalize-size (+ 5 (load.b p)) 4))))
        (incf index))
      (when (and insert-offset (null insert-index))
        (error "Inconsistency: didn't find insert-offset"))
      (unless (eql p (+ $btree_data (load.uw $btree_used)))
        (error "Inconsistency: walking node's entries didn't end up at end"))
      insert-index)))

; When we move entries around in a non-leaf nodes, the parent pointers
; need to be updated.
; This will go away if I eliminate the parent pointers and replace
; them with passing around the ancestor list.
; Doing this will make insertion and deletion slightly faster
; at the expense of making it hard to click around in a btree
; in the inspector.
(defun %btree-update-childrens-parents (disk-cache node &optional start-ptr end-ptr)
  (with-locked-page (disk-cache node nil node-buf node-buf-offset)
    (accessing-byte-array (node-buf)
      (let* ((used (load.uw (+ node-buf-offset $btree_used)))
             (p (or start-ptr (+ node-buf-offset $btree_data)))
             (max-p (or end-ptr (+ node-buf-offset $btree_data used)))
             child)
        (declare (fixnum p max-p))
        (loop
          (setq child (load.p p))
          (require-satisfies dc-vector-subtype-p disk-cache child $v_btree-node)
          (accessing-disk-cache (disk-cache child)
            (store.p node $btree_parent))
          (incf p 4)
          (when (>= p max-p)
            (unless (eql p max-p)
              (error "Inconsistency. Node scan went past expected end."))
            (return))
          (incf p (normalize-size (+ 1 (load.b p)) 4)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Here's where the guts of an insert happens.
;; We know that the key-string belongs at offset from node.
;; Insert it there if it fits.
;; Otherwise do the btree stuff:
;;   Try to shuffle things between this node and its left or right
;;     neighbor (shuffle right not implemented yet).
;;   If that doesn't work, split this node and its left (right) neighbor
;;     into three nodes.

(defun %btree-insert-in-leaf-node (disk-cache btree node offset key-string value
                                              &optional value-imm? (key-length (length key-string)))
  (accessing-disk-cache (disk-cache node)
    (let* ((free (load.uw $btree_free))
           (used (load.uw $btree_used))
           (size (normalize-size (+ 5 key-length) 4)))
      (declare (fixnum free used size))
      (if (> key-length 127)
        (error "Keys longer than 127 not supported yet."))
      (when (<= size free)
        ; Will fit in this node
        (with-locked-page (disk-cache node t node-buf node-buf-offset nil node-page)
          (let* ((bytes-to-move (- used (- offset $btree_data)))
                 (p (+ node-buf-offset offset)))
            (declare (fixnum bytes-to-move p))
            (%copy-byte-array-portion node-buf p bytes-to-move
                                      node-buf (+ p size) node-page)
            (%store-btree-entry
             node-buf p node-page
             key-string key-length value value-imm? size)
            (accessing-byte-array (node-buf node-buf-offset node-page)
              (store.w (1+ (load.uw $btree_count)) $btree_count)
              (store.w (+ used size) $btree_used)
              (store.w (- free size) $btree_free))))
        (return-from %btree-insert-in-leaf-node nil))
      ; Won't fit. Try to shuffle entries to neighbors
      (let* ((parent (load.l $btree_parent))
             (flags (load.w $btree_flags))
             (root-p (logbitp $btree_flags.root-bit flags))
             (count (load.uw $btree_count))
             (sizes (make-array (the fixnum (1+ count))))
             (node-index nil)         ; The index of this node in sizes
             right-offset parent-used
             left-offset left-neighbor
             (left-used 0)
             (left-free 0)
             (left-entry-size 0)
             (right-entry-size 0)
             right-neighbor right-used right-free)
        (declare (fixnum flags count left-used left-free left-entry-size right-entry-size)
                 (dynamic-extent sizes))
        ; Fill in sizes array
        (setq node-index (%lookup-node-sizes disk-cache node sizes count offset size))
        (unless root-p
          ; Try to shuffle to left neighbor
          (accessing-disk-cache (disk-cache parent)
            (multiple-value-setq (right-offset left-offset)
              (%btree-search-for-subnode disk-cache parent node))
            (setq parent-used (load.uw $btree_used))
            (when left-offset
              (setq left-entry-size (normalize-size (+ 5 (load.b (+ left-offset 4))) 4)
                    left-neighbor (load.l left-offset))
              (when left-neighbor
;                (break "Trying to shuffle left")
                (require-satisfies dc-vector-subtype-p
                                   disk-cache left-neighbor $v_btree-node)
                (accessing-disk-cache (disk-cache left-neighbor)
                  (setq left-free (load.uw $btree_free)
                        left-used (load.uw $btree_used)))
                (let* ((bytes-added 0)
                       (node-free free)
                       (left-still-free left-free)
                       (move-left-size 0)
                       (current-size 0)
                       (temp-string (make-string 128))
                       insert-string insert-length)
                  (declare (fixnum bytes-added node-free left-still-free move-left-size current-size))
                  (declare (dynamic-extent temp-string))
                  (dotimes (i count)
                    (setq current-size (aref sizes i)
                          move-left-size current-size)
                    (unless (<= 0 (decf left-still-free move-left-size))
                      (return))
                    (incf bytes-added move-left-size)
                    (when (or (eql i node-index)
                              (>= (incf node-free current-size) size))
                      ; Can shift to the left neighbor
;                      (break "Shuffling left")
                      (with-locked-page (disk-cache parent t parent-buf parent-buf-offset nil parent-page)
                        (with-locked-page (disk-cache left-neighbor t left-buf left-buf-offset nil left-page)
                          (with-locked-page (disk-cache node t node-buf node-buf-offset nil node-page)
                            (let* ((p (+ left-buf-offset $btree_data left-used))
                                   (bytes-to-move bytes-added))
                              (declare (fixnum p bytes-to-move))
                              ; Move link to new end of left-neighbor
                              (%copy-byte-array-portion
                               left-buf (decf p 4) 4 left-buf (+ p bytes-added) left-page)
                              ; Move entries from node to left-neighbor
                              (when (eql i node-index)
;                                (format t "~&(eql i node-index): %btree-insert-in-leaf-node")
                                (decf bytes-to-move size))
                              (%copy-byte-array-portion
                               node-buf (+ node-buf-offset $btree_data) bytes-to-move
                               left-buf p left-page)
                              (incf p bytes-to-move)
                              (when (eql i node-index)
                                (%store-btree-entry
                                 left-buf p left-page
                                 key-string key-length value value-imm? size))
                              ; update the used, free, & count fields for left-neighbor
                              (accessing-byte-array (left-buf left-buf-offset left-page)
                                (store.w (incf left-used bytes-added) $btree_used)
                                (store.w (- (load.w $btree_free) bytes-added) $btree_free)
                                (store.w (+ (load.w $btree_count) (1+ i)) $btree_count))
                              ; Update the parent pointers for the sub-nodes we moved
                              ; Left-neighbor is all set.
                              ; fixup node
                              ; bytes-to-move is number of bytes that moved from node to left-neighbor
                              (if (eql i node-index)
                                ; new entry goes to parent and is already in left-neighbor
                                (progn
                                  (decf used bytes-to-move)
                                  (incf free bytes-to-move)
                                  (%copy-byte-array-portion
                                   node-buf (+ node-buf-offset $btree_data bytes-to-move) used
                                   node-buf (+ node-buf-offset $btree_data) node-page)
                                  (accessing-byte-array (node-buf node-buf-offset node-page)
                                    (fill.b (+ $btree_data used) 0 bytes-to-move)
                                    (store.w used $btree_used)
                                    (store.w free $btree_free)
                                    (store.w (- (load.uw $btree_count) i) $btree_count))
                                  (setq insert-string key-string
                                        insert-length key-length))
                                (progn
                                  ; Store the new left-entry in insert-xxx
                                  (accessing-byte-array (node-buf nil node-page)
                                    (let ((p (+ node-buf-offset $btree_data bytes-to-move  (- 4 move-left-size))))
                                      (setq insert-length (load.b p))
                                      (load.string (incf p 1) insert-length (setq insert-string temp-string))))
                                  ; Insert the new entry into node
                                  (let* ((offset-from-data (- offset $btree_data))
                                         (bytes-before-new (- offset-from-data bytes-to-move))
                                         (bytes-after-new (- used offset-from-data)))
                                    (declare (fixnum offset-from-data bytes-before-new bytes-after-new))
                                    (%copy-byte-array-portion
                                     node-buf (+ node-buf-offset $btree_data bytes-to-move) bytes-before-new
                                     node-buf (+ node-buf-offset $btree_data) node-page)
                                    (%copy-byte-array-portion
                                     node-buf (+ node-buf-offset offset) bytes-after-new
                                     node-buf (+ node-buf-offset $btree_data bytes-before-new size))
                                    (let ((p (+ node-buf-offset $btree_data bytes-before-new)))
                                      (%store-btree-entry
                                       node-buf p node-page
                                       key-string key-length value value-imm? size)
                                      (incf p size)
                                      (accessing-byte-array (node-buf nil node-page)
                                        (let ((end-fill (- used (+ bytes-before-new size bytes-after-new))))
                                          (declare (fixnum end-fill))
                                          (when (> end-fill 0)
                                            (fill.b (+ p bytes-after-new) 0 end-fill))
                                          (accessing-byte-array (node-buf node-buf-offset node-page)
                                            (store.w (- used end-fill) $btree_used)
                                            (store.w (+ free end-fill) $btree_free)
                                            (store.w (- count i) $btree_count)))))))))))
                        ; Finally, insert the new left-entry in parent
                        (accessing-byte-array (parent-buf parent-buf-offset parent-page)
                          (let* ((insert-size (normalize-size (+ 5 insert-length) 4))
                                 (size-diff (- insert-size left-entry-size))
                                 (parent-free (load.uw $btree_free))
                                 (parent-used (load.uw $btree_used))
                                 (bytes-after-left-entry (- parent-used left-entry-size (- left-offset $btree_data))))
                            (declare (fixnum insert-size size-diff parent-free parent-used bytes-after-left-entry))
                            (when (>= parent-free size-diff)
                              ; The insert-string will fit in the parent
                              (incf parent-used size-diff)
                              (decf parent-free size-diff)
                              (%copy-byte-array-portion
                               parent-buf (+ parent-buf-offset left-offset left-entry-size) bytes-after-left-entry
                               parent-buf (+ parent-buf-offset left-offset insert-size) parent-page)
                              (when (< size-diff 0)
                                (fill.b (+ $btree_data parent-used) 0 (- size-diff)))
                              (let ((p (+ parent-buf-offset left-offset 4))
                                    (filler (- insert-size insert-length 5)))
                                (declare (fixnum p filler))
                                (accessing-byte-array (parent-buf nil parent-page)
                                  (store.b insert-length p)
                                  (incf p)
                                  (%copy-byte-array-portion
                                   insert-string 0 insert-length parent-buf p parent-page)
                                  (when (> filler 0)
                                    (incf p insert-length)
                                    (fill.b p 0 filler))))
                              (store.w parent-free $btree_free)
                              (store.w parent-used $btree_used)
;                              (format t "~&Shuffled left.")
;                              (check-btree-consistency disk-cache btree)
                              (return-from %btree-insert-in-leaf-node :left-shift))
                            ; The insert string won't fit. We have to do a recursive call
                            (%copy-byte-array-portion
                             parent-buf (+ parent-buf-offset left-offset left-entry-size) bytes-after-left-entry
                             parent-buf (+ parent-buf-offset left-offset) parent-page)
                            (fill.b (+ left-offset bytes-after-left-entry) 0 left-entry-size)
                            (store.w (- parent-used left-entry-size) $btree_used)
                            (store.w (+ parent-free left-entry-size) $btree_free)
                            (store.w (1- (load.uw $btree_count)) $btree_count)
                            (%btree-insert-in-inner-node
                             disk-cache btree parent left-offset insert-string left-neighbor
                             nil insert-length)
;                            (format t "~&Shuffled left leaf node and inserted.")
;                            (check-btree-consistency disk-cache btree)
                            (return-from %btree-insert-in-leaf-node :left-shift-and-insert)))))))))
            ; Didn't fit in left neighbor. Try right neighbor
            (accessing-disk-cache (disk-cache parent)
              (when (< (+ right-offset 4) (+ $btree_data parent-used))
                (setq right-entry-size (normalize-size (+ 5 (load.b (+ right-offset 4))) 4)
                      right-neighbor (load.l (+ right-offset right-entry-size)))))
            (when (eql $pheap-nil right-neighbor) (setq right-neighbor nil))
            (when right-neighbor
;              (format t "~&Trying to shuffle right")
              (require-satisfies dc-vector-subtype-p
                                 disk-cache right-neighbor $v_btree-node)
              (accessing-disk-cache (disk-cache right-neighbor)
                (setq right-free (load.uw $btree_free)
                      right-used (load.uw $btree_used)))
              ; Almost a copy of the left-neighbor case above
              ; Debug that code, then modify it to go here.
              )))
        ; Can't slide stuff around. Need to split two nodes into three
        ; (or one node into two if it's the root)
        (when root-p
          ; We're passing a large amount of state.
          ; Maybe it would be better to recompute some of this stuff.
          (%btree-split-root
           disk-cache btree node offset key-string key-length value value-imm?
           size used free count flags sizes node-index)
          (return-from %btree-insert-in-leaf-node :split-root))
        ; again, there's an awfully large amount of state here.
        (let ((normalized-offset (- offset $btree_data)))
          (declare (fixnum normalized-offset))
          (cond (left-neighbor
                 (%btree-split-leaf-node
                  disk-cache btree key-string key-length value value-imm?
                  (the fixnum (+ normalized-offset left-used -4)) flags
                  parent left-offset left-entry-size
                  left-neighbor left-used left-free
                  node used free))
                (right-neighbor
                 (%btree-split-leaf-node
                  disk-cache btree key-string key-length value value-imm?
                  normalized-offset flags
                  parent right-offset right-entry-size
                  node used free
                  right-neighbor right-used right-free))
                (t (error "Not root-p but no neighbors"))))
        (return-from %btree-insert-in-leaf-node :split-node)))))

(defun %btree-insert-in-inner-node (disk-cache btree node offset key-string value value-imm? key-length)
  (accessing-disk-cache (disk-cache node)
    (let* ((free (load.uw $btree_free))
           (used (load.uw $btree_used))
           (size (normalize-size (+ 5 key-length) 4)))
      (declare (fixnum free used size))
      (if (> key-length 127)
        (error "Keys longer than 127 not supported yet."))
      (when (<= size free)
        ; Will fit in this node
        (with-locked-page (disk-cache node t node-buf node-buf-offset nil node-page)
          (let* ((bytes-to-move (- used (- offset $btree_data)))
                 (p (+ node-buf-offset offset)))
            (declare (fixnum bytes-to-move p))
            (%copy-byte-array-portion node-buf p bytes-to-move
                                      node-buf (+ p size) node-page)
            (%store-btree-entry
             node-buf p node-page
             key-string key-length value value-imm? size)
            (accessing-byte-array (node-buf node-buf-offset node-page)
              (store.w (1+ (load.uw $btree_count)) $btree_count)
              (store.w (+ used size) $btree_used)
              (store.w (- free size) $btree_free))))
        (return-from %btree-insert-in-inner-node nil))
      ; Won't fit. Try to shuffle entries to neighbors
      (let* ((parent (load.l $btree_parent))
             (flags (load.w $btree_flags))
             (root-p (logbitp $btree_flags.root-bit flags))
             (count (load.uw $btree_count))
             (sizes (make-array (the fixnum (1+ count))))
             (node-index nil)         ; The index of this node in sizes
             right-offset parent-used
             left-offset left-neighbor
             (left-used 0)
             (left-free 0)
             (left-entry-size 0)
             (right-entry-size 0)
             right-neighbor right-used right-free)
        (declare (fixnum flags count left-used left-free left-entry-size right-entry-size)
                 (dynamic-extent sizes))
        (require-satisfies dc-vector-subtype-p disk-cache value $v_btree-node)
        ; Fill in sizes array
        (setq node-index (%lookup-node-sizes disk-cache node sizes count offset size))
        (unless root-p
          ; Try to shuffle to left neighbor
          (accessing-disk-cache (disk-cache parent)
            (multiple-value-setq (right-offset left-offset)
              (%btree-search-for-subnode disk-cache parent node))
            (setq parent-used (load.uw $btree_used))
            (when left-offset
              (setq left-entry-size (normalize-size (+ 5 (load.b (+ left-offset 4))) 4)
                    left-neighbor (load.l left-offset))
              (when left-neighbor
;                (break "Trying to shuffle left")
                (require-satisfies dc-vector-subtype-p
                                   disk-cache left-neighbor $v_btree-node)
                (accessing-disk-cache (disk-cache left-neighbor)
                  (setq left-free (load.uw $btree_free)
                        left-used (load.uw $btree_used)))
                (let* ((bytes-added 0)
                       (node-free free)
                       (left-entry-string-size (- left-entry-size 4))
                       (left-still-free left-free)
                       (last-size left-entry-size)
                       (move-left-size 0)
                       (current-size 0)
                       (temp-string (make-string 128))
                       insert-string insert-length)
                  (declare (fixnum bytes-added node-free left-entry-string-size
                                   left-still-free last-size move-left-size current-size))
                  (declare (dynamic-extent temp-string))
                  (dotimes (i count)
                    (setq current-size (aref sizes i)
                          move-left-size last-size
                          last-size current-size)
                    (unless (<= 0 (decf left-still-free move-left-size))
                      (return))
                    (incf bytes-added move-left-size)
                    (when (or (eql i node-index)
                              (>= (incf node-free current-size) size))
                      ; Can shift to the left neighbor
;                      (break "Shuffling left inner node")
                      (with-locked-page (disk-cache parent t parent-buf parent-buf-offset nil parent-page)
                        (with-locked-page (disk-cache left-neighbor t left-buf left-buf-offset nil left-page)
                          (with-locked-page (disk-cache node t node-buf node-buf-offset nil node-page)
                            (let* ((p (+ left-buf-offset $btree_data left-used))
                                   (child-update-pointer 0)
                                   (bytes-to-move bytes-added))
                              (declare (fixnum p child-update-pointer bytes-to-move))
                              ; Copy key from parent into left neighbor
                              (%copy-byte-array-portion
                               parent-buf (+ parent-buf-offset left-offset 4)
                               left-entry-string-size left-buf p left-page)
                              (incf p left-entry-string-size)
                              (setq child-update-pointer p)
                              (decf bytes-to-move left-entry-string-size)
                              ; Move entries from node to left-neighbor
                              (when (eql i node-index)
;                                (format t "~&(eql i node-index): %btree-insert-in-inner-node")
                                (decf bytes-to-move 4))
                              (%copy-byte-array-portion
                               node-buf (+ node-buf-offset $btree_data) bytes-to-move
                               left-buf p left-page)
                              (incf p bytes-to-move)
                              (when (eql i node-index)
                                (accessing-byte-array (left-buf nil left-page)
                                  (store.p value p value-imm?)))
                              ; update the used, free, & count fields for left-neighbor
                              (accessing-byte-array (left-buf left-buf-offset left-page)
                                (store.w (incf left-used bytes-added) $btree_used)
                                (store.w (- (load.w $btree_free) bytes-added) $btree_free)
                                (store.w (+ (load.w $btree_count) (1+ i)) $btree_count))
                              ; Update the parent pointers for the sub-nodes we moved
                              (%btree-update-childrens-parents
                               disk-cache left-neighbor child-update-pointer)
                              ; Left-neighbor is all set.
                              ; fixup node
                              ; bytes-to-move is number of bytes that moved from node to left-neighbor
                              (if (eql i node-index)
                                ; new entry goes to parent
                                (progn
                                  (decf used bytes-to-move)
                                  (incf free bytes-to-move)
                                  (%copy-byte-array-portion
                                   node-buf (+ node-buf-offset $btree_data bytes-to-move) used
                                   node-buf (+ node-buf-offset $btree_data) node-page)
                                  (accessing-byte-array (node-buf node-buf-offset node-page)
                                    (fill.b (+ $btree_data used) 0 bytes-to-move)
                                    (store.w used $btree_used)
                                    (store.w free $btree_free)
                                    (store.w (- (load.uw $btree_count) i) $btree_count))
                                  (setq insert-string key-string
                                        insert-length key-length))
                                (progn
                                  ; Store the new left-entry in insert-xxx
                                  (accessing-byte-array (node-buf nil node-page)
                                    (let ((p (+ node-buf-offset $btree_data bytes-to-move)))
                                      (setq insert-length (load.b p))
                                      (load.string (incf p 1) insert-length (setq insert-string temp-string))))
                                  ; Insert the new entry into node
                                  (incf bytes-to-move (- current-size 4))
                                  (let* ((offset-from-data (- offset $btree_data))
                                         (bytes-before-new (- offset-from-data bytes-to-move))
                                         (bytes-after-new (- used offset-from-data)))
                                    (declare (fixnum offset-from-data bytes-before-new bytes-after-new))
                                    (%copy-byte-array-portion
                                     node-buf (+ node-buf-offset $btree_data bytes-to-move) bytes-before-new
                                     node-buf (+ node-buf-offset $btree_data) node-page)
                                    (%copy-byte-array-portion
                                     node-buf (+ node-buf-offset offset) bytes-after-new
                                     node-buf (+ node-buf-offset $btree_data bytes-before-new size))
                                    (let ((p (+ node-buf-offset $btree_data bytes-before-new)))
                                      (%store-btree-entry
                                       node-buf p node-page
                                       key-string key-length value value-imm? size)
                                      (incf p size)
                                      (accessing-byte-array (node-buf nil node-page)
                                        (let ((end-fill (- used (+ bytes-before-new size bytes-after-new))))
                                          (declare (fixnum end-fill))
                                          (when (> end-fill 0)
                                            (fill.b (+ p bytes-after-new) 0 end-fill))
                                          (accessing-byte-array (node-buf node-buf-offset node-page)
                                            (store.w (- used end-fill) $btree_used)
                                            (store.w (+ free end-fill) $btree_free)
                                            (store.w (- count i) $btree_count)))))))))))
                        ; Finally, insert the new left-entry in parent
                        (accessing-byte-array (parent-buf parent-buf-offset parent-page)
                          (let* ((insert-size (normalize-size (+ 5 insert-length) 4))
                                 (size-diff (- insert-size left-entry-size))
                                 (parent-free (load.uw $btree_free))
                                 (parent-used (load.uw $btree_used))
                                 (bytes-after-left-entry (- parent-used left-entry-size (- left-offset $btree_data))))
                            (declare (fixnum insert-size size-diff parent-free parent-used bytes-after-left-entry))
                            (when (>= parent-free size-diff)
                              ; The insert-string will fit in the parent
                              (incf parent-used size-diff)
                              (decf parent-free size-diff)
                              (%copy-byte-array-portion
                               parent-buf (+ parent-buf-offset left-offset left-entry-size) bytes-after-left-entry
                               parent-buf (+ parent-buf-offset left-offset insert-size) parent-page)
                              (when (< size-diff 0)
                                (fill.b (+ $btree_data parent-used) 0 (- size-diff)))
                              (let ((p (+ parent-buf-offset left-offset 4))
                                    (filler (- insert-size insert-length 5)))
                                (declare (fixnum p filler))
                                (accessing-byte-array (parent-buf nil parent-page)
                                  (store.b insert-length p)
                                  (incf p)
                                  (%copy-byte-array-portion
                                   insert-string 0 insert-length parent-buf p parent-page)
                                  (when (> filler 0)
                                    (incf p insert-length)
                                    (fill.b p 0 filler))))
                              (store.w parent-free $btree_free)
                              (store.w parent-used $btree_used)
;                              (format t "~&Shuffled left inner node.")
;                              (check-btree-consistency disk-cache btree)
                              (return-from %btree-insert-in-inner-node :left-shift))
                            ; The insert string won't fit. We have to do a recursive call
                            (%copy-byte-array-portion
                             parent-buf (+ parent-buf-offset left-offset left-entry-size) bytes-after-left-entry
                             parent-buf (+ parent-buf-offset left-offset) parent-page)
                            (fill.b (+ left-offset bytes-after-left-entry) 0 left-entry-size)
                            (store.w (- parent-used left-entry-size) $btree_used)
                            (store.w (+ parent-free left-entry-size) $btree_free)
                            (store.w (1- (load.uw $btree_count)) $btree_count)
                            (%btree-insert-in-inner-node
                             disk-cache btree parent left-offset insert-string left-neighbor
                             nil insert-length)
;                            (format t "~&Shuffled left inner node and inserted.")
;                            (check-btree-consistency disk-cache btree)
                            (return-from %btree-insert-in-inner-node :left-shift-and-insert)))))))))
            ; Didn't fit in left neighbor. Try right neighbor
            (accessing-disk-cache (disk-cache parent)
              (when (< (+ right-offset 4) (+ $btree_data parent-used))
                (setq right-entry-size (normalize-size (+ 5 (load.b (+ right-offset 4))) 4)
                      right-neighbor (load.l (+ right-offset right-entry-size)))))
            (when (eql $pheap-nil right-neighbor) (setq right-neighbor nil))
            (when right-neighbor
;              (format t "~&Trying to shuffle right")
              (require-satisfies dc-vector-subtype-p
                                 disk-cache right-neighbor $v_btree-node)
              (accessing-disk-cache (disk-cache right-neighbor)
                (setq right-free (load.uw $btree_free)
                      right-used (load.uw $btree_used)))
              ; Almost a copy of the left-neighbor case above
              ; Debug that code, then modify it to go here.
              )))
        ; Can't slide stuff around. Need to split two nodes into three
        ; (or one node into two if it's the root)
        (when root-p
          ; We're passing a large amount of state.
          ; Maybe it would be better to recompute some of this stuff.
          (%btree-split-root
           disk-cache btree node offset key-string key-length value value-imm?
           size used free count flags sizes node-index)
          (return-from %btree-insert-in-inner-node :split-root))
        ; again, there's an awfully large amount of state here.
        (let ((normalized-offset (- offset $btree_data)))
          (declare (fixnum normalized-offset))
          (cond (left-neighbor
                 (%btree-split-inner-node
                  disk-cache btree key-string key-length value value-imm?
                  (the fixnum (+ normalized-offset left-used -4)) flags
                  parent left-offset left-entry-size
                  left-neighbor left-used left-free
                  node used free))
                (right-neighbor
                 (%btree-split-inner-node
                  disk-cache btree key-string key-length value value-imm?
                  normalized-offset flags
                  parent right-offset right-entry-size
                  node used free
                  right-neighbor right-used right-free))
                (t (error "Not root-p but no neighbors"))))
        (return-from %btree-insert-in-inner-node :split-node)))))

(defun %btree-split-root (disk-cache btree node offset key-string key-length value value-imm?
                                     size used free count flags sizes node-index)
  (declare (fixnum offset key-length size used free count flags))
;  (break "Splitting root")
  (let* ((parent (dc-cons-btree-node
                  disk-cache btree btree (ash 1 $btree_flags.root-bit)))
         (new-flags (logand flags (lognot (ash 1 $btree_flags.root-bit))))
         (right-neighbor (dc-cons-btree-node disk-cache btree parent new-flags))
         (leaf-p (logbitp $btree_flags.leaf-bit flags))
         (save-used used))
    (declare (fixnum save-used))
    (with-locked-page (disk-cache node t node-buf node-buf-offset nil node-page)
      (declare (fixnum node-buf-offset))
      (with-locked-page (disk-cache right-neighbor t right-buf right-buf-offset nil right-page)
        (declare (fixnum right-buf-offset))
        (let* ((right-used 0)
               (right-free 0)
               (bytes-before-new (- offset $btree_data))
               (total-bytes 0)
               (bytes-to-keep 0)
               (bytes-to-copy 0)
               (max-bytes-to-keep 0)
               (last-size 0)
               (last-length 0)
               (split-index 0))
          (declare (fixnum right-used right-free
                           bytes-before-new total-bytes bytes-to-keep bytes-to-copy
                           max-bytes-to-keep last-size last-length split-index))
          (accessing-byte-array (right-buf right-buf-offset right-page)
            (setq right-used (load.uw $btree_used)
                  right-free (load.uw $btree_free)
                  total-bytes (+ used size)
                  max-bytes-to-keep (ash total-bytes -1)))
          (dotimes (i (1+ count)
                      (error "Didn't half fill new node on root split."))
            (when (>= (incf bytes-to-keep (setq last-size (svref sizes i)))
                      max-bytes-to-keep)
              (setq split-index i)
              (return)))
          (setq bytes-to-copy (- total-bytes bytes-to-keep))
          (incf right-free (the fixnum (- right-used bytes-to-copy)))
          (setq right-used bytes-to-copy)
          (let* ((ptr (+ node-buf-offset $btree_data bytes-to-keep))
                 (right-ptr (+ right-buf-offset $btree_data))
                 (new-went-right nil))
            (declare (fixnum ptr right-ptr))
;            (break "About to copy to right-neighbor")
            (if (> bytes-to-keep bytes-before-new)
              (decf ptr size)
              (progn
                (setq new-went-right t)
                (%copy-byte-array-portion
                 node-buf ptr (decf bytes-before-new bytes-to-keep)
                 right-buf right-ptr right-page)
                (incf ptr bytes-before-new)
                (incf right-ptr bytes-before-new)
                (decf bytes-to-copy bytes-before-new)
                (%store-btree-entry
                 right-buf right-ptr right-page key-string key-length value value-imm? size)
                (incf right-ptr size)
                (decf bytes-to-copy size)))
            (when (> bytes-to-copy 0)
              (%copy-byte-array-portion
               node-buf ptr bytes-to-copy right-buf right-ptr right-page)
              (incf ptr bytes-to-copy)
              (incf right-ptr bytes-to-copy))
            (accessing-byte-array (right-buf right-buf-offset right-page)
              (store.w right-used $btree_used)
              (store.w right-free $btree_free)
              (store.w (the fixnum (- count split-index)) $btree_count))
            (incf free (- used bytes-to-keep))
            (setq used bytes-to-keep)
            (unless new-went-right
              (setq ptr (+ node-buf-offset offset))
              (unless (eql split-index node-index)
                (%copy-byte-array-portion
                 node-buf ptr (- used bytes-before-new)
                 node-buf (the fixnum (+ ptr size)) node-page))
              (%store-btree-entry
               node-buf ptr node-page
               key-string key-length value value-imm? size))
            (setq last-length (- last-size 4))
            (with-locked-page (disk-cache parent t parent-buf parent-buf-offset nil parent-page)
              (accessing-byte-array (parent-buf nil parent-page)
                (let ((p (+ parent-buf-offset $btree_data)))
                  (declare (fixnum p))
                  (store.l node p)
                  (incf p 4)
                  (setq ptr (+ node-buf-offset $btree_data used (- last-length)))
                  (%copy-byte-array-portion
                   node-buf ptr last-length parent-buf p)
                  (incf p last-length)
                  (incf ptr last-length)
                  (store.l right-neighbor p)))
              (accessing-byte-array (parent-buf parent-buf-offset parent-page)
                (let* ((parent-used (+ last-size 4))
                       (diff (- parent-used (load.uw $btree_used))))
                  (declare (fixnum parent-used diff))
                  (store.w parent-used $btree_used)
                  (store.w (the fixnum (- (load.uw $btree_free) diff)) $btree_free)
                  (store.w 1 $btree_count))))
            (if leaf-p
              (progn
                (incf used 4)
                (decf free 4)
                (accessing-byte-array (node-buf nil node-page)
                  (store.l right-neighbor ptr))
                (incf split-index))     ; leaves keep the parent's entry
              (progn
                (decf used last-length)
                (incf free last-length)))
            (accessing-byte-array (node-buf (+ node-buf-offset $btree_data) node-page)
              (fill.b used 0 (the fixnum (- save-used used)))))
          (accessing-byte-array (node-buf node-buf-offset node-page)
            (store.l parent $btree_parent)
            (store.w used $btree_used)
            (store.w free $btree_free)
            (store.w split-index $btree_count)
            (store.w new-flags $btree_flags)))))
    (accessing-disk-cache (disk-cache)
      (svset.p btree $btree.root parent)
      (svset.p btree $btree.depth (1+ (svref.p btree $btree.depth)) t))
    (unless leaf-p
      (%btree-update-childrens-parents disk-cache right-neighbor))
;    (format t "~&Root is split")
;    (check-btree-consistency disk-cache btree)
    parent))

; Insert middle-string into parent before left-string.
; Then left-string is guaranteed to fit in same parent node

(defun %btree-split-leaf-node
       (disk-cache btree key-string key-length value value-imm?
                   insert-offset flags
                   parent parent-offset parent-entry-size
                   left-node left-used left-free
                   right-node right-used right-free)
  (declare (fixnum key-length insert-offset parent-offset parent-entry-size
                   left-used left-free right-used right-free))
;  (break "%split-btree-leaf-node")
  (with-locked-page (disk-cache parent t parent-buf parent-buf-offset nil parent-page)
    (declare (fixnum parent-buf-offset))
    (let ((new-parent-key-string (make-string 128))
          (new-parent-key-length 0)
          (middle-node (dc-cons-btree-node disk-cache btree parent flags)))
      (declare (dynamic-extent new-key-string)
               (fixnum new-parent-key-length))
      (with-locked-page (disk-cache left-node t left-buf left-buf-offset nil left-page)
        (declare (fixnum left-buf-offset))
        (with-locked-page (disk-cache right-node t right-buf right-buf-offset nil right-page)
          (declare (fixnum right-buf-offset))
          (let* ((left-count (accessing-byte-array (left-buf left-buf-offset)
                               (load.uw $btree_count)))
                 (right-count (accessing-byte-array (right-buf right-buf-offset)
                                (load.uw $btree_count)))
                 (size (normalize-size (+ 5 key-length) 4))
                 (total-count (1+ (the fixnum (+ left-count right-count))))
                 (total-size (+ left-used right-used -4 size))
                 (target-size (ceiling total-size 3))
                 (sizes (make-array total-count))
                 (new-left-count 0)
                 (new-left-used 0)
                 (last-left-size 0)
                 (new-middle-count 0)
                 (new-middle-used-sans-parent 0)
                 (new-middle-used 0)
                 (last-middle-size 0)
                 (new-right-count 0)
                 (new-right-used 0)
                 (insert-goes-left (< insert-offset (- left-used 4))))
            (declare (fixnum left-count right-count size
                             total-count total-size target-size
                             new-left-count new-left-used last-left-size
                             new-middle-count new-middle-used-sans-parent new-middle-used last-middle-size
                             new-right-count new-right-used)
                     (dynamic-extent sizes))
            ; Fillin all-sizes with sizes from left-node, right-node, and key-string
            (%lookup-node-sizes
             disk-cache left-node sizes left-count
             (and insert-goes-left (+ insert-offset $btree_data))
             size)
            (%lookup-node-sizes
             disk-cache right-node sizes right-count
             (and (not insert-goes-left) (+ (- insert-offset (- left-used 4)) $btree_data))
             size (if insert-goes-left (1+ left-count) left-count))
            (let ((i 0))
              (loop
                (incf new-left-used (setq last-left-size (aref sizes i)))
                (incf new-left-count)
                (incf i)
                (when (>= new-left-used target-size)
                  (return)))
              (setq target-size (ash (- total-size new-left-used) -1))
              (loop
                (incf new-middle-used (setq last-middle-size (aref sizes i)))
                (incf new-middle-used-sans-parent last-middle-size)
                (incf new-middle-count)
                (incf i)
                (when (>= new-middle-used target-size)
                  (return)))
              (setq new-right-used (- total-size new-left-used new-middle-used)
                    new-right-count (- total-count
                                       (the fixnum (+ new-left-count new-middle-count)))))
            (unless (and (>= left-used new-left-used) (>= right-used new-right-used))
              (error "One of the 2 full nodes was not full."))
            (with-locked-page (disk-cache middle-node t middle-buf middle-buf-offset nil middle-page)
              (declare (fixnum middle-buf-offset))
              (let* ((left-ptr (+ left-buf-offset $btree_data new-left-used))
                     (left-copy (- left-used new-left-used 4))          ; don't copy pointer to right node
                     (middle-ptr (+ middle-buf-offset $btree_data))
                     (right-copy (- right-used new-right-used))
                     (right-dont-copy new-right-used)
                     (right-ptr (+ right-buf-offset $btree_data))
                     (parent-string-ptr (+ parent-buf-offset parent-offset 4))
                     (parent-string-size (- parent-entry-size 4))
                     (insert-location nil))
                (declare (fixnum left-ptr left-copy middle-ptr
                                 right-copy right-dont-copy right-ptr
                                 parent-string-ptr parent-string-size))
                ; Don't copy bytes that are for the new value/key-string
                (cond ((< insert-offset new-left-used)
                       (setq insert-location :left)
                       (decf left-ptr size)
                       (incf left-copy size))
                      ((>= insert-offset (+ new-left-used new-middle-used-sans-parent))
                       (setq insert-location :right)
                       (incf right-copy size)
                       (decf right-dont-copy size))
                      (t (setq insert-location :middle)))
                ; slide end of left buf to the middle one
                (%copy-byte-array-portion
                 left-buf left-ptr left-copy middle-buf middle-ptr middle-page)
                (incf middle-ptr left-copy)
                ; and clear the now garbage bytes
                (accessing-byte-array (left-buf nil left-page)
                  (fill.b left-ptr 0 (the fixnum (+ left-copy 4))))
                ; copy the beginning of the right buffer to the middle one
                (%copy-byte-array-portion
                 right-buf right-ptr right-copy middle-buf middle-ptr middle-page)
                ; slide the remaining portion of the right buffer left
                (%copy-byte-array-portion
                 right-buf (+ right-ptr right-copy) right-dont-copy
                 right-buf right-ptr right-page)
                ; and clear the garbage.
                (accessing-byte-array (right-buf nil right-page)
                  (fill.b (+ right-ptr right-dont-copy) 0 right-copy))
;                (format t "~&New key went ~s" insert-location)
                (ecase insert-location
                  (:left
                   (setq left-ptr (+ left-buf-offset $btree_data insert-offset))
                   (%copy-byte-array-portion
                    left-buf left-ptr (- left-used left-copy insert-offset)
                    left-buf (+ left-ptr size) left-page)
                   (%store-btree-entry left-buf left-ptr left-page
                                       key-string key-length value value-imm? size))
                  (:middle
                   (decf insert-offset new-left-used)
                   (setq middle-ptr (+ middle-buf-offset $btree_data insert-offset))
                   (%copy-byte-array-portion
                    middle-buf middle-ptr (- new-middle-used insert-offset size)
                    middle-buf (+ middle-ptr size) middle-page)
                   (%store-btree-entry middle-buf middle-ptr middle-page
                                       key-string key-length value value-imm? size))
                  (:right
                   (decf insert-offset (+ left-used -4 right-copy))
                   (setq right-ptr (+ right-buf-offset $btree_data insert-offset))
                   (%copy-byte-array-portion
                    right-buf right-ptr (- right-dont-copy insert-offset)
                    right-buf (+ right-ptr size) right-page)
                   (%store-btree-entry right-buf right-ptr right-page
                                       key-string key-length value value-imm? size)))
                ; Put the last string in left-node & middle-node into parent.
                (decf last-left-size 4)
                (decf last-middle-size 4)
                (let ((parent-used 0)
                      (parent-free 0)
                      (parent-diff (- last-middle-size parent-string-size)))
                  (declare (fixnum parent-used parent-free parent-diff))
                  (accessing-byte-array (parent-buf parent-buf-offset)
                    (setq parent-used (load.uw $btree_used)
                          parent-free (load.uw $btree_free)))
                  (setq left-ptr (+ left-buf-offset $btree_data (- new-left-used last-left-size))
                        middle-ptr (+ middle-buf-offset $btree_data
                                      (- new-middle-used last-middle-size)))
                  (accessing-byte-array (left-buf)
                    (setq new-parent-key-length (load.b left-ptr)))
                  (%copy-byte-array-portion
                   left-buf (1+ left-ptr) new-parent-key-length new-parent-key-string 0)
                  (incf new-left-used 4)
                  (incf new-middle-used 4)
                  (accessing-byte-array (left-buf nil left-page)
                    (store.l middle-node (+ left-ptr last-left-size)))
                  (accessing-byte-array (middle-buf nil left-page)
                    (store.l right-node (+ middle-ptr last-middle-size)))
                  (accessing-byte-array (left-buf left-buf-offset left-page)
                    (decf left-free (- new-left-used left-used))
                    (store.w left-free $btree_free)
                    (store.w new-left-used $btree_used)
                    (store.w new-left-count $btree_count))
                  (accessing-byte-array (middle-buf middle-buf-offset middle-page)
                    (store.w (- (load.uw $btree_free) (- new-middle-used (load.uw $btree_used)))
                             $btree_free)
                    (store.w new-middle-used $btree_used)
                    (store.w new-middle-count $btree_count))
                  (accessing-byte-array (right-buf right-buf-offset right-page)
                    (decf right-free (- new-right-used right-used))
                    (store.w right-free $btree_free)
                    (store.w new-right-used $btree_used)
                    (store.w new-right-count $btree_count))
                  (let* ((parent-string-offset (- parent-string-ptr $btree_data parent-buf-offset))
                         (parent-after-string (- parent-used parent-string-offset parent-string-size)))
                      (declare (fixnum parent-string-offset parent-after-string))
                    (if (>= parent-free parent-diff)
                      ; The new left-node entry fits in the parent
                      (progn
;                        (format t "~&New middle-node fits")
                        (%copy-byte-array-portion
                         parent-buf (+ parent-string-ptr parent-string-size) parent-after-string
                         parent-buf (+ parent-string-ptr last-middle-size) parent-page)
                        (accessing-byte-array (parent-buf nil parent-page)
                          (store.l middle-node (the fixnum (- parent-string-ptr 4))))
                        (%copy-byte-array-portion
                         middle-buf middle-ptr last-middle-size
                         parent-buf parent-string-ptr parent-page)
                        (incf parent-used parent-diff)
                        (decf parent-free parent-diff)
                        (accessing-byte-array (parent-buf parent-buf-offset parent-page)
                          (store.w parent-used $btree_used)
                          (store.w parent-free $btree_free)
                          (when (< parent-diff 0)
                            (fill.b (+ $btree_data parent-used) 0 (- parent-diff)))))
                      ; the new middle-node entry doesn't fit. Must insert it the hard way
                      (let* ((last-middle-string-size (accessing-byte-array (middle-buf) (load.b middle-ptr)))
                             (last-middle-string (make-string last-middle-string-size))
                             (parent-ptr (- parent-string-ptr 4)))
                        (declare (dynamic-extent last-middle-string)
                                 (fixnum parent-ptr last-middle-string-size))
;                        (format t "~&New middle-node didn't fit: %btree-split-leaf-node.")
                        (decf parent-used parent-entry-size)
                        (incf parent-free parent-entry-size)
                        (%copy-byte-array-portion
                         parent-buf (+ parent-ptr parent-entry-size) parent-after-string
                         parent-buf parent-ptr parent-page)
                        (accessing-byte-array (parent-buf nil parent-page)
                          (fill.b (+ parent-ptr parent-after-string) 0 parent-entry-size))
                        (accessing-byte-array (parent-buf parent-buf-offset parent-page)
                          (store.w parent-used $btree_used)
                          (store.w parent-free $btree_free)
                          (store.w (1- (load.uw $btree_count)) $btree_count))
                        (%copy-byte-array-portion
                         middle-buf (1+ middle-ptr) last-middle-string-size last-middle-string 0)
                        (%btree-insert-in-inner-node
                         disk-cache btree parent parent-offset
                         last-middle-string middle-node nil last-middle-string-size)
                        ; parent may have changed.
                        (setq parent (accessing-byte-array (middle-buf middle-buf-offset)
                                       (load.l $btree_parent))
                              parent-offset (%btree-search-for-subnode
                                             disk-cache parent middle-node))
                        (accessing-byte-array (left-buf left-buf-offset left-page)
                          (unless (eql parent (load.l $btree_parent))
                            (store.l parent $btree_parent))))))))))))
      ; finally, we can insert the new key in the (possibly new) parent
      (%btree-insert-in-inner-node disk-cache btree parent parent-offset
                                   new-parent-key-string left-node nil new-parent-key-length)
;      (format t "~&End of %btree-split-leaf-node: #x~x #x~x" left-node right-node)
;      (check-btree-consistency disk-cache btree)
      )))

(defun %btree-split-inner-node
       (disk-cache btree key-string key-length value value-imm?
                   insert-offset flags
                   parent parent-offset parent-entry-size
                   left-node left-used left-free
                   right-node right-used right-free)
  (declare (fixnum key-length insert-offset parent-offset parent-entry-size
                   left-used left-free right-used right-free))
;  (break "%btree-split-inner-node")
  (with-locked-page (disk-cache parent t parent-buf parent-buf-offset nil parent-page)
    (declare (fixnum parent-buf-offset))
    (let ((new-parent-key-string (make-string 128))
          (new-parent-key-length 0)
          (middle-node (dc-cons-btree-node disk-cache btree parent flags)))
      (declare (dynamic-extent new-key-string)
               (fixnum new-parent-key-length))
      (with-locked-page (disk-cache left-node t left-buf left-buf-offset nil left-page)
        (declare (fixnum left-buf-offset))
        (with-locked-page (disk-cache right-node t right-buf right-buf-offset nil right-page)
          (declare (fixnum right-buf-offset))
          (let* ((left-count (accessing-byte-array (left-buf left-buf-offset)
                               (load.uw $btree_count)))
                 (right-count (accessing-byte-array (right-buf right-buf-offset)
                                (load.uw $btree_count)))
                 (size (normalize-size (+ 5 key-length) 4))
                 (total-count (1+ (the fixnum (+ left-count right-count))))
                 (total-size (+ left-used parent-entry-size right-used -4 size))
                 (target-size (ceiling total-size 3))
                 (sizes (make-array total-count))
                 (new-left-count 0)
                 (new-left-used 0)
                 (last-left-size 0)
                 (new-middle-count 0)
                 (new-middle-used-sans-parent 0)
                 (new-middle-used 0)
                 (last-middle-size 0)
                 (new-right-count 0)
                 (new-right-used 0)
                 (insert-goes-left (< insert-offset (- left-used 4))))
            (declare (fixnum left-count right-count size
                             total-count total-size target-size
                             new-left-count new-left-used last-left-size
                             new-middle-count new-middle-used-sans-parent new-middle-used last-middle-size
                             new-right-count new-right-used)
                     (dynamic-extent sizes))
            ; Fillin all-sizes with sizes from left-node, right-node, and key-string
            (%lookup-node-sizes
             disk-cache left-node sizes left-count
             (and insert-goes-left (+ insert-offset $btree_data))
             size)
            (%lookup-node-sizes
             disk-cache right-node sizes right-count
             (and (not insert-goes-left) (+ (- insert-offset (- left-used 4)) $btree_data))
             size (if insert-goes-left (1+ left-count) left-count))
            (let ((i 0))
              (loop
                (incf new-left-used (setq last-left-size (aref sizes i)))
                (incf new-left-count)
                (incf i)
                (when (>= new-left-used target-size)
                  (return)))
              (setq target-size (ash (- total-size new-left-used) -1))
              (setq new-middle-used parent-entry-size)
              (loop
                (incf new-middle-used (setq last-middle-size (aref sizes i)))
                (incf new-middle-used-sans-parent last-middle-size)
                (incf new-middle-count)
                (incf i)
                (when (>= new-middle-used target-size)
                  (return)))
              (setq new-right-used (- total-size new-left-used new-middle-used)
                    new-right-count (- total-count (+ new-left-count new-middle-count))))
            (unless (and (>= left-used new-left-used) (>= right-used new-right-used))
              (error "One of the 2 full nodes was not full."))
            (with-locked-page (disk-cache middle-node t middle-buf middle-buf-offset nil middle-page)
              (declare (fixnum middle-buf-offset))
              (let* ((left-ptr (+ left-buf-offset $btree_data new-left-used))
                     (left-copy (- left-used new-left-used))
                     (middle-ptr (+ middle-buf-offset $btree_data))
                     (right-copy (- right-used new-right-used))
                     (right-dont-copy new-right-used)
                     (right-ptr (+ right-buf-offset $btree_data))
                     (parent-string-ptr (+ parent-buf-offset parent-offset 4))
                     (parent-string-size (- parent-entry-size 4))
                     (insert-location nil))
                (declare (fixnum left-ptr left-copy middle-ptr
                                 right-copy right-dont-copy right-ptr
                                 parent-string-ptr parent-string-size))
                ; Don't copy bytes that are for the new value/key-string
                (cond ((< insert-offset new-left-used)
                       (setq insert-location :left)
                       (decf left-ptr size)
                       (incf left-copy size))
                      ((>= insert-offset (+ new-left-used new-middle-used-sans-parent))
                       (setq insert-location :right)
                       (incf right-copy size)
                       (decf right-dont-copy size))
                      (t (setq insert-location :middle)))
                ; slide end of left buf to the middle one
                (%copy-byte-array-portion
                 left-buf left-ptr left-copy middle-buf middle-ptr middle-page)
                (incf middle-ptr left-copy)
                ; and clear the now garbage bytes
                (accessing-byte-array (left-buf nil left-page)
                  (fill.b left-ptr 0 left-copy))
                ; unless we're at the leaves, copy the parent entry into the middle node
                (%copy-byte-array-portion
                 parent-buf parent-string-ptr parent-string-size
                 middle-buf middle-ptr middle-page)
                (incf middle-ptr parent-string-size)
                ; copy the beginning of the right buffer to the middle one
                (%copy-byte-array-portion
                 right-buf right-ptr right-copy middle-buf middle-ptr middle-page)
                ; slide the remaining portion of the right buffer left
                (%copy-byte-array-portion
                 right-buf (+ right-ptr right-copy) right-dont-copy
                 right-buf right-ptr right-page)
                ; and clear the garbage.
                (accessing-byte-array (right-buf nil right-page)
                  (fill.b (+ right-ptr right-dont-copy) 0 right-copy))
;                (format t "~&New key went ~s" insert-location)
                (ecase insert-location
                  (:left
                   (setq left-ptr (+ left-buf-offset $btree_data insert-offset))
                   (%copy-byte-array-portion
                    left-buf left-ptr (- left-used left-copy insert-offset)
                    left-buf (+ left-ptr size) left-page)
                   (%store-btree-entry left-buf left-ptr left-page
                                       key-string key-length value value-imm? size))
                  (:middle
                   (decf insert-offset new-left-used)
                   (unless insert-goes-left
                     (incf insert-offset parent-entry-size))
                   (setq middle-ptr (+ middle-buf-offset $btree_data insert-offset))
                   (%copy-byte-array-portion
                    middle-buf middle-ptr (- new-middle-used insert-offset size)
                    middle-buf (+ middle-ptr size) middle-page)
                   (%store-btree-entry middle-buf middle-ptr middle-page
                                       key-string key-length value value-imm? size))
                  (:right
                   (decf insert-offset (+ left-used -4 right-copy))
                   (setq right-ptr (+ right-buf-offset $btree_data insert-offset))
                   (%copy-byte-array-portion
                    right-buf right-ptr (- right-dont-copy insert-offset)
                    right-buf (+ right-ptr size) right-page)
                   (%store-btree-entry right-buf right-ptr right-page
                                       key-string key-length value value-imm? size)))
                ; Put the last string in left-node & middle-node into parent.
                (decf last-left-size 4)
                (decf last-middle-size 4)
                (let ((parent-used 0)
                      (parent-free 0)
                      (parent-diff (- last-middle-size parent-string-size)))
                  (declare (dynamic-extent last-middle-string)
                           (fixnum parent-used parent-free parent-diff))
                  (accessing-byte-array (parent-buf parent-buf-offset)
                    (setq parent-used (load.uw $btree_used)
                          parent-free (load.uw $btree_free)))
                  (setq left-ptr (+ left-buf-offset $btree_data (- new-left-used last-left-size))
                        middle-ptr (+ middle-buf-offset $btree_data
                                      (- new-middle-used last-middle-size)))
                  (accessing-byte-array (left-buf)
                    (setq new-parent-key-length (load.b left-ptr)))
                  (%copy-byte-array-portion
                   left-buf (1+ left-ptr) new-parent-key-length new-parent-key-string 0)
                  (decf new-left-used last-left-size)
                  (decf new-left-count)
                  (decf new-middle-used last-middle-size)
                  (accessing-byte-array (left-buf nil middle-page)
                    (fill.b left-ptr 0 last-left-size))
                  (accessing-byte-array (left-buf left-buf-offset left-page)
                    (decf left-free (- new-left-used left-used))
                    (store.w left-free $btree_free)
                    (store.w new-left-used $btree_used)
                    (store.w new-left-count $btree_count))
                  (accessing-byte-array (middle-buf middle-buf-offset middle-page)
                    (store.w (- (load.uw $btree_free) (- new-middle-used (load.uw $btree_used)))
                             $btree_free)
                    (store.w new-middle-used $btree_used)
                    (store.w new-middle-count $btree_count))
                  (accessing-byte-array (right-buf right-buf-offset right-page)
                    (decf right-free (- new-right-used right-used))
                    (store.w right-free $btree_free)
                    (store.w new-right-used $btree_used)
                    (store.w new-right-count $btree_count))
                  (let* ((parent-string-offset (- parent-string-ptr $btree_data parent-buf-offset))
                         (parent-after-string (- parent-used parent-string-offset parent-string-size)))
                      (declare (fixnum parent-string-offset parent-after-string))
                    (if (>= parent-free parent-diff)
                      ; The new left-node entry fits in the parent
                      (progn
;                        (format t "~&New middle-node fits: %btree-split-inner-node")
                        (%copy-byte-array-portion
                         parent-buf (+ parent-string-ptr parent-string-size) parent-after-string
                         parent-buf (+ parent-string-ptr last-middle-size) parent-page)
                        (accessing-byte-array (parent-buf nil parent-page)
                          (store.l middle-node (the fixnum (- parent-string-ptr 4))))
                        (%copy-byte-array-portion
                         middle-buf middle-ptr last-middle-size
                         parent-buf parent-string-ptr parent-page)
                        (incf parent-used parent-diff)
                        (decf parent-free parent-diff)
                        (accessing-byte-array (parent-buf parent-buf-offset parent-page)
                          (store.w parent-used $btree_used)
                          (store.w parent-free $btree_free)
                          (when (< parent-diff 0)
                            (fill.b (+ $btree_data parent-used) 0 (- parent-diff)))))
                      ; the new middle-node entry doesn't fit. Must insert it the hard way
                      (let* ((last-middle-string-size (accessing-byte-array (middle-buf)
                                                        (load.b left-ptr)))
                             (last-middle-string (make-string last-middle-string-size))
                             (parent-ptr (- parent-string-ptr 4)))
                        (declare (dynamic-extent last-middle-string)
                                 (fixnum parent-ptr last-middle-string-size))
;                        (format t "~&New middle-node didn't fit: %btree-split-inner-node.")
                        (decf parent-used parent-entry-size)
                        (incf parent-free parent-entry-size)
                        (decf parent-string-offset 4)
                        (%copy-byte-array-portion
                         parent-buf (+ parent-ptr parent-entry-size) parent-after-string
                         parent-buf parent-ptr parent-page)
                        (accessing-byte-array (parent-buf nil parent-page)
                          (fill.b (+ parent-ptr parent-after-string) 0 parent-entry-size))
                        (accessing-byte-array (parent-buf parent-buf-offset parent-page)
                          (store.w parent-used $btree_used)
                          (store.w parent-free $btree_free)
                          (store.w (1- (load.uw $btree_count)) $btree_count))
                        (%copy-byte-array-portion
                         middle-buf (1+ middle-ptr) last-middle-string-size last-middle-string 0)
                        (%btree-insert-in-inner-node
                         disk-cache btree parent parent-offset
                         last-middle-string middle-node nil last-middle-string-size)
                        ; parent may have changed.
                        (setq parent (accessing-byte-array (middle-buf middle-buf-offset)
                                       (load.l $btree_parent))
                              parent-offset (%btree-search-for-subnode
                                             disk-cache parent middle-node))
                        (accessing-byte-array (left-buf left-buf-offset left-page)
                          (unless (eql parent (load.l $btree_parent))
                            (store.l parent $btree_parent)))))
                    (accessing-byte-array (middle-buf nil left-page)
                      (fill.b middle-ptr 0 last-middle-size))))
                (%btree-update-childrens-parents disk-cache middle-node))))))
      ; finally, we can insert the new key in the (possibly new) parent
      (%btree-insert-in-inner-node disk-cache btree parent parent-offset
                                   new-parent-key-string left-node nil new-parent-key-length)
;      (format t "~&End of %btree-split-inner-node: #x~x #x~x" left-node right-node)
;      (check-btree-consistency disk-cache btree)
      )))

;; Store a single entry into a buffer.
(defun %store-btree-entry (buf offset page string string-length value value-imm? &optional size)
  (declare (fixnum offset string-length))
  (let ((p offset))
    (declare (fixnum p))
    (accessing-byte-array (buf nil page)
      (store.p value p value-imm?)
      (store.b string-length (incf p 4))
      (store.string string (incf p 1) string-length)
      (incf p string-length)
      (let* ((bytes (+ 5 string-length))
             (filler (- (or size (setq size (normalize-size bytes 4)))
                        bytes)))
        (declare (fixnum bytes filler))
        (when (> filler 0)
          ; This is for us poor humans.
          (fill.b p 0 filler)))))
  size)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Code to support deletion

(defun %btree-delete-from-node (disk-cache btree node offset leaf-p)
  (declare (fixnum offset))
  (with-locked-page (disk-cache node t node-buf node-buf-offset nil node-page)
    (accessing-byte-array (node-buf node-buf-offset node-page)
      (let* ((ptr (+ node-buf-offset offset))
             (size (normalize-size (+ 5 (accessing-byte-array (node-buf)
                                          (load.b (+ ptr 4))))
                                   4))
             (used (load.uw $btree_used))
             (free (load.uw $btree_free))
             (count (load.uw $btree_count))
             (bytes-after-entry (- used size (- offset $btree_data))))
        (declare (fixnum ptr size used free count bytes-after-entry))
        (unless leaf-p
          (incf ptr 4)                  ; not a mistake. Look how it's called.
          (decf bytes-after-entry 4))
        (%copy-byte-array-portion node-buf (+ ptr size) bytes-after-entry
                                  node-buf ptr node-page)
        (accessing-byte-array (node-buf nil node-page)
          (fill.b (+ ptr bytes-after-entry) 0 size))
        (store.w (decf used size) $btree_used)
        (store.w (incf free size) $btree_free)
        (store.w (decf count) $btree_count)
        ; If this is the right-most entry in a leaf node, we could add here
        ; to find the entry higher in the tree and replace it.
        ; Probably not worth the effort.
        (when (<= used free)
          ; This node is <= half full. Try to merge or balance with a neighbor
          (let* ((parent (load.l $btree_parent))
                 left-offset middle-offset right-offset
                 left-neighbor right-neighbor
                 (parent-used 0)
                 (left-free 0)
                 (right-free 0))
            (declare (fixnum parent-used left-free right-free))
            (if (eql parent btree)
              ; This is the root. Nothing to do unless it's empty
              (when (eql count 0)
                (let ((new-root (accessing-byte-array (node-buf node-buf-offset)
                                  (unless (logbitp $btree_flags.leaf-bit (load.uw $btree_flags))
                                    (load.l $btree_data)))))
                  (when new-root
                    (with-locked-page (disk-cache new-root t buf offset nil page)
                      (accessing-byte-array (buf offset)
                        (store.l btree $btree_parent)
                        (store.w (logior (ash 1 $btree_flags.root-bit) (load.uw $btree_flags))
                                 $btree_flags)))
                    ; Really need to lock this vector before doing any updating
                    (accessing-disk-cache (disk-cache)
                      (svset.p btree $btree.root new-root))
;                    (break "Deleted root node")
                    (dc-free-btree-node disk-cache btree node))))
              (with-locked-page (disk-cache parent nil parent-buf parent-buf-offset)
                (multiple-value-setq (middle-offset left-offset)
                  (%btree-search-for-subnode disk-cache parent node))
                (unless middle-offset
                  (error "Couldn't find #x~x in #x~x in ~s" node parent disk-cache))
                (accessing-byte-array (parent-buf parent-buf-offset)
                  (setq parent-used (load.uw $btree_used))
                  (when left-offset
                    (setq left-neighbor (load.l left-offset))
                    (accessing-disk-cache (disk-cache left-neighbor)
                      (setq left-free (load.uw $btree_free))))
                  (unless (>= middle-offset (+ $btree_data parent-used -4))
                    (setq right-offset (+ middle-offset
                                          (normalize-size (+ 5 (load.b (+ 4 middle-offset)))
                                                          4))
                          right-neighbor (load.l right-offset))
                    (accessing-disk-cache (disk-cache right-neighbor)
                      (setq right-free (load.uw $btree_free)))))
                (let ((balance-function (if leaf-p
                                          '%balance-leaf-node-after-deletion
                                          '%balance-inner-node-after-deletion)))
                  (cond ((and left-neighbor (>= left-free right-free))
                         (funcall balance-function
                                  disk-cache btree left-neighbor left-free node free
                                  parent left-offset))
                        (right-neighbor
                         (funcall balance-function
                                  disk-cache btree node free right-neighbor right-free
                                  parent middle-offset))))))))))))

(defun %balance-leaf-node-after-deletion
       (disk-cache btree left-node left-free right-node right-free parent-node parent-offset)
  (declare (fixnum left-free right-free parent-offset))
  (with-locked-page (disk-cache parent-node t parent-buf parent-buf-offset nil parent-page)
    (with-locked-page (disk-cache left-node t left-buf left-buf-offset nil left-page)
      (with-locked-page (disk-cache right-node t right-buf right-buf-offset nil right-page)
        (let ((left-used 0)
              (left-count 0)
              (right-used 0)
              (right-count 0))
          (declare (fixnum left-used left-count right-used right-count))
          (accessing-byte-array (left-buf left-buf-offset)
            (setq left-used (load.uw $btree_used)
                  left-count (load.uw $btree_count)))
          (accessing-byte-array (right-buf right-buf-offset)
            (setq right-used (load.uw $btree_used)
                  right-count (load.uw $btree_count)))
          (let ((total-size (+ left-used right-used -4))
                (space-available (+ left-used left-free)))
            (declare (fixnum total-size space-available))
            (if (<= total-size space-available)
              (progn
                ; Can merge the two nodes
                (%copy-byte-array-portion
                 right-buf (+ right-buf-offset $btree_data) right-used
                 left-buf (+ left-buf-offset $btree_data left-used -4))
                (decf left-free (- total-size left-used))
                (setq left-used total-size)
                (incf left-count right-count)
                (accessing-byte-array (left-buf left-buf-offset left-page)
                  (store.w left-used $btree_used)
                  (store.w left-free $btree_free)
                  (store.w left-count $btree_count))
                (%btree-delete-from-node disk-cache btree parent-node parent-offset nil)
                (dc-free-btree-node disk-cache btree right-node)
                :merged)
              (progn
                ; Can't merge so balance as well as we can.
                (incf total-size 4)     ; restore the pointer form left-node to right-node
                (let* ((total-count (+ left-count right-count))
                       (sizes (make-array total-count))
                       (target-size (ash total-size -1))
                       (new-left-used 4)
                       (new-right-used 0)
                       (used-diff 0)
                       (split-index 0))
                  (declare (fixnum total-count target-size new-left-used new-right-used
                                   used-diff split-index)
                           (dynamic-extent sizes))
                  (%lookup-node-sizes disk-cache left-node sizes left-count)
                  (%lookup-node-sizes
                   disk-cache right-node sizes right-count nil nil left-count)
                  (dotimes (i total-count (error "Should have merged"))
                    (incf new-left-used (svref sizes i))
                    (when (>= new-left-used target-size)
                      (setq split-index i)
                      (return)))
                  (setq used-diff (- new-left-used left-used))
                  (unless (eql used-diff 0)
                    (setq new-right-used (- right-used used-diff))
                    (if (> used-diff 0)
                      (let ((left-ptr (+ left-buf-offset $btree_data left-used -4))
                            (right-ptr (+ right-buf-offset $btree_data)))
                        (declare (fixnum left-ptr right-ptr))
                        (%copy-byte-array-portion
                         right-buf right-ptr used-diff left-buf left-ptr left-page)
                        (incf left-ptr used-diff)
                        (accessing-byte-array (left-buf nil left-page)
                          (store.l right-node left-ptr))
                        (%copy-byte-array-portion
                         right-buf (+ right-ptr used-diff) new-right-used
                         right-buf right-ptr right-page)
                        (incf right-ptr new-right-used)
                        (accessing-byte-array (right-buf nil right-page)
                          (fill.b right-ptr 0 used-diff)))
                      (let ((diff-used (- used-diff))
                            (left-ptr (+ left-buf-offset $btree_data new-left-used -4))
                            (right-ptr (+ right-buf-offset $btree_data)))
                        (declare (fixnum diff-used left-ptr right-ptr))
                        (%copy-byte-array-portion
                         right-buf right-ptr right-used
                         right-buf (+ right-ptr diff-used) right-page)
                        (%copy-byte-array-portion
                         left-buf left-ptr diff-used right-buf right-ptr right-page)
                        (accessing-byte-array (left-buf nil left-page)
                          (fill.b left-ptr 0 (+ diff-used 4))
                          (store.l right-node left-ptr))))
                    (decf left-free used-diff)
                    (incf right-free used-diff)
                    (setq left-count (1+ split-index)
                          right-count (- total-count left-count))
                    (accessing-byte-array (left-buf left-buf-offset)
                      (store.w new-left-used $btree_used)
                      (store.w left-free $btree_free)
                      (store.w left-count $btree_count))
                    (accessing-byte-array (right-buf right-buf-offset)
                      (store.w new-right-used $btree_used)
                      (store.w right-free $btree_free)
                      (store.w right-count $btree_count))
                    (let* ((last-left-size (svref sizes split-index))
                           (left-ptr (- (+ left-buf-offset $btree_data new-left-used)
                                        last-left-size))
                           (parent-entry-size 0)
                           (size-diff 0)
                           (parent-used 0)
                           (parent-free 0))
                      (declare (fixnum last-left-size left-ptr parent-entry-size
                                       size-diff parent-free parent-used))
                      (accessing-byte-array (parent-buf parent-buf-offset)
                        (setq parent-entry-size (normalize-size
                                                 (+ 5 (load.b (+ parent-offset 4)))
                                                 4)
                              size-diff (- last-left-size parent-entry-size)
                              parent-used (load.uw $btree_used)
                              parent-free (load.uw $btree_free)))
                      (if (>= parent-free size-diff)
                        ; Modified parent-entry fits
                        (let ((parent-ptr (+ parent-buf-offset parent-offset))
                              (new-parent-used (+ parent-used size-diff)))
                          (declare (fixnum parent-ptr new-parent-used))
                          (%copy-byte-array-portion
                           parent-buf (+ parent-ptr parent-entry-size)
                           (- parent-used (- parent-offset $btree_data) parent-entry-size)
                           parent-buf (+ parent-ptr last-left-size) parent-page)
                          (when (< size-diff 0)
                            (accessing-byte-array (parent-buf nil parent-page)
                              (fill.b (+ parent-buf-offset $btree_data new-parent-used)
                                      0 (- size-diff))))
                          (incf parent-ptr 4)
                          (decf last-left-size 4)
                          (%copy-byte-array-portion
                           left-buf left-ptr last-left-size
                           parent-buf parent-ptr parent-page)
                          (decf parent-free size-diff)
                          (accessing-byte-array (parent-buf parent-buf-offset)
                            (store.w new-parent-used $btree_used)
                            (store.w parent-free $btree_free)))
                        ; Modified parent-entry doesn't fit
                        (let ((parent-ptr (+ parent-buf-offset parent-offset))
                              (new-parent-used (- parent-used parent-entry-size)))
                          (%copy-byte-array-portion
                           parent-buf (+ parent-ptr parent-entry-size)
                           (- parent-used (- parent-offset $btree_data) parent-entry-size)
                           parent-buf parent-ptr parent-page)
                          (incf parent-free parent-entry-size)
                          (accessing-byte-array (parent-buf parent-buf-offset parent-page)
                            (fill.b (+ $btree_data new-parent-used) 0 parent-entry-size)
                            (store.w new-parent-used $btree_used)
                            (store.w parent-free $btree_free)
                            (store.w (1- (load.uw $btree_count)) $btree_count))
                          (let* ((key-length (accessing-byte-array (left-buf)
                                               (load.b left-ptr)))
                                 (key-string (make-string key-length)))
                            (declare (fixnum key-length)
                                     (dynamic-extent key-string))
                            (%copy-byte-array-portion
                             left-buf (incf left-ptr) key-length key-string 0)
                            (%btree-insert-in-inner-node
                             disk-cache btree parent-node parent-offset
                             key-string left-node nil key-length)))))))
                :balanced))))))))

; Node 7e01 is ready to call this to merge.
; Tested  (< left-used-diff 0) case
; Need to test (>= left-used-diff 0) case.
; c-x c-e here and eval the advice at the bottom of the file
;
(defun %balance-inner-node-after-deletion
       (disk-cache btree left-node left-free right-node right-free parent-node parent-offset)
  (declare (fixnum left-free right-free parent-offset))
  (with-locked-page (disk-cache parent-node t parent-buf parent-buf-offset nil parent-page)
    (with-locked-page (disk-cache left-node t left-buf left-buf-offset nil left-page)
      (with-locked-page (disk-cache right-node t right-buf right-buf-offset nil right-page)
        (let ((left-used 0)
              (left-count 0)
              (right-used 0)
              (right-count 0))
          (declare (fixnum left-used left-count right-used right-count))
          (accessing-byte-array (left-buf left-buf-offset)
            (setq left-used (load.uw $btree_used)
                  left-count (load.uw $btree_count)))
          (accessing-byte-array (right-buf right-buf-offset)
            (setq right-used (load.uw $btree_used)
                  right-count (load.uw $btree_count)))
          (let* ((parent-ptr (+ parent-buf-offset parent-offset 4))
                 (parent-entry-size (accessing-byte-array (parent-buf)
                                      (normalize-size (+ 5 (load.b parent-ptr)) 4)))
                 (parent-string-size (- parent-entry-size 4))
                 (total-size (+ left-used parent-string-size right-used))
                 (space-available (+ left-used left-free)))
            (declare (fixnum parent-ptr parent-entry-size parent-string-size
                             total-size space-available))
            (if (<= total-size space-available)
              ; Can merge the two nodes
              (let ((left-ptr (+ left-buf-offset $btree_data left-used))
                    (right-ptr (+ right-buf-offset $btree_data)))
                (declare (fixnum left-ptr))
                (%copy-byte-array-portion
                 parent-buf parent-ptr parent-string-size
                 left-buf left-ptr left-page)
                (incf parent-ptr parent-string-size)
                (incf left-ptr parent-string-size)
                (%copy-byte-array-portion
                 right-buf right-ptr right-used left-buf left-ptr)
                (decf left-free (- total-size left-used))
                (setq left-used total-size)
                (incf left-count (1+ right-count))
                (accessing-byte-array (left-buf left-buf-offset left-page)
                  (store.w left-used $btree_used)
                  (store.w left-free $btree_free)
                  (store.w left-count $btree_count))
                (%btree-update-childrens-parents disk-cache left-node left-ptr)
                (%btree-delete-from-node disk-cache btree parent-node parent-offset nil)
                (dc-free-btree-node disk-cache btree right-node)
                :merged)
              ; Can't merge, so balance as well as we can.
              (let* ((total-count (+ left-count right-count))
                     (sizes (make-array (1+ total-count)))
                     (new-left-used 4)
                     (new-parent-entry-size 0)
                     (new-right-used 0)
                     (left-used-diff 0)
                     (right-used-diff 0)
                     (bytes-to-copy 0)
                     (split-index 0)
                     (new-parent-string-size 0)
                     (new-parent-string (make-string 128))
                     child-update-node child-update-ptr child-update-end)
                (declare (fixnum total-count new-left-used new-parent-entry-size
                                 new-right-used left-used-diff right-used-diff
                                 bytes-to-copy split-index new-parent-string-size)
                         (dynamic-extent sizes new-parent-string))
                (%lookup-node-sizes disk-cache left-node sizes left-count)
                (setf (svref sizes left-count) parent-entry-size)
                (%lookup-node-sizes
                 disk-cache right-node sizes right-count nil nil (1+ left-count))
                (setq new-parent-entry-size (svref sizes 0))
                (dotimes (i total-count (error "Should have merged"))
                  (incf new-left-used new-parent-entry-size)
                  (setq new-parent-entry-size (svref sizes (the fixnum (1+ i))))
                  (when (>= new-left-used (- total-size new-left-used new-parent-entry-size))
                    (setq split-index i)
                    (return)))
                (setq left-used-diff (- new-left-used left-used))
                (unless (eql left-used-diff 0)
                  (setq new-parent-string-size (- new-parent-entry-size 4)
                        new-right-used (- total-size new-left-used new-parent-string-size)
                        right-used-diff (- right-used new-right-used))
                  (if (> left-used-diff 0)
                    (let* ((left-ptr (+ left-buf-offset $btree_data left-used))
                           (right-start-ptr (+ right-buf-offset $btree_data))
                           (right-ptr right-start-ptr))
                      (declare (fixnum left-ptr right-ptr))
                      (%copy-byte-array-portion
                       parent-buf parent-ptr parent-string-size left-buf left-ptr left-page)
                      (incf left-ptr parent-string-size)
                      (setq bytes-to-copy (- left-used-diff parent-string-size))
                      (%copy-byte-array-portion
                       right-buf right-ptr bytes-to-copy left-buf left-ptr left-page)
                      (setq child-update-node left-node
                            child-update-ptr left-ptr)
                      (incf right-ptr bytes-to-copy)
                      (%copy-byte-array-portion
                       right-buf right-ptr new-parent-string-size new-parent-string 0)
                      (incf right-ptr new-parent-string-size)
                      (%copy-byte-array-portion
                       right-buf right-ptr new-right-used
                       right-buf right-start-ptr right-page)
                      (incf right-start-ptr new-right-used)
                      (accessing-byte-array (right-buf nil right-page)
                        (fill.b right-start-ptr 0 right-used-diff)))
                    (let* ((left-diff-used (- left-used-diff))
                           (right-diff-used (- right-used-diff))
                           (left-start-ptr (+ left-buf-offset $btree_data new-left-used))
                           (left-ptr left-start-ptr)
                           (right-ptr (+ right-buf-offset $btree_data)))
                      (declare (fixnum left-diff-used right-diff-used
                                       left-start-ptr left-ptr right-ptr))
                      (%copy-byte-array-portion
                       left-buf left-ptr new-parent-string-size new-parent-string 0)
                      (incf left-ptr new-parent-string-size)
                      (setq bytes-to-copy (- left-diff-used new-parent-string-size))
                      (%copy-byte-array-portion
                       right-buf right-ptr right-used
                       right-buf (+ right-ptr right-diff-used) right-page)
                      (%copy-byte-array-portion
                       left-buf left-ptr bytes-to-copy right-buf right-ptr right-page)
                      (incf right-ptr bytes-to-copy)
                      (setq child-update-node right-node
                            child-update-end right-ptr)
                      (%copy-byte-array-portion
                       parent-buf parent-ptr parent-string-size
                       right-buf right-ptr right-page)
                      (accessing-byte-array (left-buf nil left-page)
                        (fill.b left-start-ptr 0 left-diff-used))))
                  (decf left-free left-used-diff)
                  (incf right-free right-used-diff)
                  (setq left-count (1+ split-index)
                        right-count (- total-count left-count))
                  (accessing-byte-array (left-buf left-buf-offset)
                    (store.w new-left-used $btree_used)
                    (store.w left-free $btree_free)
                    (store.w left-count $btree_count))
                  (accessing-byte-array (right-buf right-buf-offset)
                    (store.w new-right-used $btree_used)
                    (store.w right-free $btree_free)
                    (store.w right-count $btree_count))
                  (%btree-update-childrens-parents
                   disk-cache child-update-node child-update-ptr child-update-end)
                  (let* ((size-diff (- new-parent-string-size parent-string-size))
                         (parent-used 0)
                         (parent-free 0))
                    (declare (fixnum size-diff parent-free parent-used))
                    (accessing-byte-array (parent-buf parent-buf-offset)
                      (setq parent-used (load.uw $btree_used)
                            parent-free (load.uw $btree_free)))
                    (if (>= parent-free size-diff)
                      ; Modified parent-entry fits
                      (let ((new-parent-used (+ parent-used size-diff)))
                        (declare (fixnum parent-ptr new-parent-used))
                        (%copy-byte-array-portion
                         parent-buf (+ parent-ptr parent-string-size)
                         (- parent-used (- parent-offset $btree_data) parent-entry-size)
                         parent-buf (+ parent-ptr new-parent-string-size) parent-page)
                        (when (< size-diff 0)
                          (accessing-byte-array (parent-buf nil parent-page)
                            (fill.b (+ parent-buf-offset $btree_data new-parent-used)
                                    0 (- size-diff))))
                        (%copy-byte-array-portion
                         new-parent-string 0 new-parent-string-size
                         parent-buf parent-ptr parent-page)
                        (decf parent-free size-diff)
                        (accessing-byte-array (parent-buf parent-buf-offset)
                          (store.w new-parent-used $btree_used)
                          (store.w parent-free $btree_free)))
                      ; Modified parent-entry doesn't fit
                      (let ((new-parent-used (- parent-used parent-entry-size)))
                        (decf parent-ptr 4)         ; point at left-node pointer
                        (%copy-byte-array-portion
                         parent-buf (+ parent-ptr parent-entry-size)
                         (- parent-used (- parent-offset $btree_data) parent-entry-size)
                         parent-buf parent-ptr parent-page)
                        (incf parent-free parent-entry-size)
                        (accessing-byte-array (parent-buf parent-buf-offset parent-page)
                          (fill.b new-parent-used 0 parent-entry-size)
                          (store.w new-parent-used $btree_used)
                          (store.w parent-free $btree_free)
                          (store.w (1- (load.uw $btree_count)) $btree_count))
                        (let* ((key-length (accessing-byte-array (new-parent-string)
                                             (load.b 0))))
                          (declare (fixnum key-length))
                          (%copy-byte-array-portion
                           new-parent-string 1 key-length new-parent-string 0)
                          (%btree-insert-in-inner-node
                           disk-cache btree parent-node parent-offset
                           new-parent-string left-node nil key-length)))))
                  :balanced))))))))
;  (check-btree-consistency disk-cache btree)
  )





; Comment this out before release
(defun init-temp-btree ()
  (declare (special pheap dc b))
  (when (boundp 'pheap)
    (close-pheap pheap))
  (delete-file "temp.pheap")
  (create-pheap "temp.pheap")
  (setq pheap (open-pheap "temp.pheap")
        dc (pheap-disk-cache pheap))
  (dolist (w (windows :class 'inspector::inspector-window))
    (window-close w))
  (setq b (dc-make-btree dc))
  (let ((w (inspect dc)))
    (set-view-size w #@(413 384))
    (scroll-to-address (inspector::inspector-view w) (dc-%svref dc b $btree.root))))

(defvar *symbols* nil)
(defvar *value-offset* 0)

(defun *symbols* ()
  (let ((syms *symbols*))
    (unless syms
      (let ((hash (make-hash-table :test 'equal)))
        (do-symbols (s)
          (unless (gethash (symbol-name s) hash)
            (setf (gethash (symbol-name s) hash) t)
            (push s syms))))
      (setq *symbols* syms
            *value-offset* 0))
    syms))

(defun store-symbols (&optional (step-sym 0) check? (check-sym 0))
  (declare (special dc b))
  (let ((syms (*symbols*))
        (check-check-sym? nil)
        (i 0))
    (dolist (s syms)
      (let ((string (symbol-name s))
            (value (+ i *value-offset*)))
        (if (eq s step-sym)
          (step
           (dc-btree-store dc b string (require-type value 'fixnum) t))
          (dc-btree-store dc b string (require-type value 'fixnum) t))
        (when (eql s check-sym) (setq check-check-sym? i))
        (incf i)
        (when check-check-sym?
          (unless (eql check-check-sym? (dc-btree-lookup dc b (symbol-name check-sym)))
            (cerror "Continue" "Can't find ~s" check-sym)))
        (when (and check? (or (not (fixnump check?))
                              (eql 0 (mod i check?))))
          (format t "~&Checking ~d..." i)
          (check-symbols s)
          (terpri))))
    i))

(defun check-symbols (&optional (upto-and-including 0))
  (declare (special dc b))
  (let ((i 0))
    (dolist (s (*symbols*))
      (let ((was (dc-btree-lookup dc b (symbol-name s)))
            (value (+ i *value-offset*)))
        (unless (eql was value)
          (cerror "Continue"
                  "Sym: ~s, was: ~s, sb: ~s" s was value))
        (incf i)
        (when (eq s upto-and-including)
          (return))))
    i))

(defun delete-symbols (&optional (count nil) (check-period nil))
  (declare (special dc b))
  (let ((check-count (or check-period most-positive-fixnum)))
    (dotimes (i (or count (length *symbols*)))
      (when (null *symbols*) (return))
      (incf *value-offset*)
      (dc-btree-delete dc b (symbol-name (pop *symbols*)))
      (when (<= (decf check-count) 0)
        (setq check-count check-period)
        (format t "~&Checking ~d..." i)
        (check-symbols)
        (terpri)))))

(defun sort-syms-upto (sym)
  (let ((first-n (let ((res nil))
                   (dolist (s *symbols* (error "Not found"))
                     (push s res)
                     (when (eq s sym) (return res))))))
    (sort first-n #'string<)))

(defun btree-test (&optional (step-sym 0))
  (init-temp-btree)
  (store-symbols step-sym))

; Checks consistency and returns how full the btree is.
(defun check-btree-consistency (disk-cache btree &optional check-nodes-and-count?)
  (let ((root (accessing-disk-cache (disk-cache)
                (svref.p btree $btree.root))))
    (multiple-value-bind (free used nodes count)
                         (check-btree-node-consistency disk-cache root btree (%btree-leaf-node-p disk-cache root))
      (when check-nodes-and-count?
        (let ((missing-nodes (- (accessing-disk-cache (disk-cache)
                                  (svref.p btree $btree.nodes))
                                nodes)))
          (unless (eql missing-nodes 0)
            (cerror "Continue" "~d. missing nodes" missing-nodes)))
        (let ((missing-entries (- (accessing-disk-cache (disk-cache)
                                    (svref.p btree $btree.count))
                                  count)))
          (unless (eql 0 missing-entries)
            (cerror "Continue" "~d. missing entries" missing-entries))))
      (values (/ used (float (+ free used)))
              nodes
              count))))

(defun check-btree-node-consistency (disk-cache node parent better-be-leaf-p)
  (require-satisfies dc-vector-subtype-p disk-cache node $v_btree-node)
  (accessing-disk-cache (disk-cache node)
    (let* ((free (load.uw $btree_free))
           (used (load.uw $btree_used))
           (count (load.uw $btree_count))
           (nodes 1)
           (sizes (make-array (1+ count)))
           (leaf? (%btree-leaf-node-p disk-cache node))
           (total-count (if leaf? count 0))
           (p $btree_data))
      (declare (fixnum free used count p)
               (dynamic-extent sizes))
      (unless (eq (not leaf?) (not better-be-leaf-p))
        (cerror "Continue."
                "node: #x~x, parent: #x~x, better-be-leaf-p: ~s, leaf?: ~s"
                node parent better-be-leaf-p leaf?))
      (unless (eql parent (load.l $btree_parent))
        (error "parent should be: #x~x, was: #x~x" parent (load.l $btree_parent)))
      (unless (eql 488 (+ free used))
        (cerror "Continue."
                "~&(+ free used) is wrong. Node: #x~x, free: #x~x, used: #x~x~%"
                node free used))
      (%lookup-node-sizes disk-cache node sizes count)
      (setf (aref sizes count) 0)
      (unless leaf?
        (let ((child-leaf-p (%btree-leaf-node-p disk-cache (load.l p))))
          (dotimes (i (1+ count))
            (multiple-value-bind (c-free c-used c-nodes c-count)
                                 (check-btree-node-consistency disk-cache (load.l p) node child-leaf-p)
              (incf free c-free)
              (incf used c-used)
              (incf nodes c-nodes)
              (incf total-count c-count))
            (incf p (aref sizes i)))))
      (values free used nodes total-count))))

#|
(advise %btree-insert-in-node
        (destructuring-bind (dc b node offset key-string value &optional value-imm? (key-length (length key-string))) arglist
          (declare (ignore offset value value-imm?))
          (if (or (%btree-leaf-node-p dc node)
                  (<= (normalize-size (+ 5 key-length))
                      (accessing-disk-cache (dc node) (load.uw $btree_free))))
            (:do-it)
            (step (:do-it))))
        :when :around)

(advise %balance-inner-node-after-deletion
        (step (:do-it))
        :when :around)
|#